ghc-lib 0.20211201 → 0.20220103
raw patch · 87 files changed
+4601/−3659 lines, 87 filesdep ~ghc-lib-parser
Dependency ranges changed: ghc-lib-parser
Files
- compiler/GHC.hs +124/−59
- compiler/GHC/Cmm/Config.hs +32/−0
- compiler/GHC/Cmm/Dataflow.hs +46/−31
- compiler/GHC/Cmm/Info/Build.hs +17/−19
- compiler/GHC/Cmm/LayoutStack.hs +28/−27
- compiler/GHC/Cmm/Lint.hs +17/−0
- compiler/GHC/Cmm/Opt.hs +14/−4
- compiler/GHC/Cmm/Pipeline.hs +31/−35
- compiler/GHC/Cmm/Sink.hs +1/−1
- compiler/GHC/Cmm/Switch/Implement.hs +3/−5
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +205/−92
- compiler/GHC/CmmToAsm/AArch64/Instr.hs +1/−2
- compiler/GHC/CmmToAsm/AArch64/Ppr.hs +2/−2
- compiler/GHC/CmmToAsm/CFG.hs +1/−1
- compiler/GHC/CmmToAsm/Config.hs +63/−0
- compiler/GHC/CmmToAsm/PIC.hs +17/−9
- compiler/GHC/CmmToAsm/PPC/Instr.hs +1/−2
- compiler/GHC/CmmToAsm/X86/CodeGen.hs +10/−1
- compiler/GHC/CmmToAsm/X86/Instr.hs +1/−2
- compiler/GHC/CmmToC.hs +112/−11
- compiler/GHC/CmmToLlvm.hs +20/−21
- compiler/GHC/CmmToLlvm/Base.hs +36/−47
- compiler/GHC/CmmToLlvm/CodeGen.hs +180/−80
- compiler/GHC/CmmToLlvm/Config.hs +31/−0
- compiler/GHC/CmmToLlvm/Data.hs +4/−3
- compiler/GHC/CmmToLlvm/Ppr.hs +10/−12
- compiler/GHC/Core/Opt/Pipeline.hs +14/−15
- compiler/GHC/Core/Opt/SetLevels.hs +3/−3
- compiler/GHC/Core/Opt/Simplify.hs +1/−1
- compiler/GHC/Core/Opt/SpecConstr.hs +1/−1
- compiler/GHC/Core/Opt/Specialise.hs +1/−1
- compiler/GHC/CoreToStg/Prep.hs +3/−3
- compiler/GHC/Driver/Backpack.hs +46/−34
- compiler/GHC/Driver/CodeOutput.hs +6/−4
- compiler/GHC/Driver/Config/Cmm.hs +33/−0
- compiler/GHC/Driver/Config/CmmToAsm.hs +2/−2
- compiler/GHC/Driver/Config/CmmToLlvm.hs +30/−0
- compiler/GHC/Driver/Config/Finder.hs +5/−0
- compiler/GHC/Driver/Main.hs +39/−30
- compiler/GHC/Driver/Make.hs +2539/−2443
- compiler/GHC/Driver/MakeFile.hs +17/−21
- compiler/GHC/Driver/Pipeline.hs +36/−17
- compiler/GHC/Driver/Pipeline/Execute.hs +41/−30
- compiler/GHC/Driver/Pipeline/LogQueue.hs +24/−2
- compiler/GHC/HsToCore.hs +2/−2
- compiler/GHC/HsToCore/Binds.hs +1/−1
- compiler/GHC/HsToCore/Expr.hs +1/−1
- compiler/GHC/HsToCore/Match.hs +2/−2
- compiler/GHC/HsToCore/Usage.hs +4/−3
- compiler/GHC/Iface/Errors.hs +2/−2
- compiler/GHC/Iface/Load.hs +37/−43
- compiler/GHC/Iface/Make.hs +2/−2
- compiler/GHC/Iface/Recomp.hs +57/−48
- compiler/GHC/Iface/Recomp/Flags.hs +1/−1
- compiler/GHC/Iface/Tidy.hs +0/−103
- compiler/GHC/IfaceToCore.hs +4/−11
- compiler/GHC/Linker/Loader.hs +123/−40
- compiler/GHC/Linker/Static.hs +1/−28
- compiler/GHC/Llvm.hs +0/−3
- compiler/GHC/Llvm/Ppr.hs +54/−52
- compiler/GHC/Llvm/Types.hs +0/−16
- compiler/GHC/Rename/Expr.hs +7/−7
- compiler/GHC/Rename/Names.hs +33/−23
- compiler/GHC/Runtime/Eval.hs +4/−4
- compiler/GHC/Runtime/Heap/Inspect.hs +1/−2
- compiler/GHC/Runtime/Loader.hs +9/−7
- compiler/GHC/StgToCmm/Prim.hs +129/−4
- compiler/GHC/StgToCmm/Ticky.hs +11/−10
- compiler/GHC/SysTools/Tasks.hs +14/−2
- compiler/GHC/Tc/Gen/App.hs +2/−2
- compiler/GHC/Tc/Gen/Export.hs +1/−1
- compiler/GHC/Tc/Gen/Splice.hs +36/−29
- compiler/GHC/Tc/Instance/Family.hs +6/−4
- compiler/GHC/Tc/Module.hs +16/−35
- compiler/GHC/Tc/Plugin.hs +2/−9
- compiler/GHC/Tc/Solver.hs +4/−4
- compiler/GHC/Tc/Solver/Canonical.hs +13/−4
- compiler/GHC/Tc/Utils/Backpack.hs +11/−31
- compiler/GHC/Tc/Utils/Env.hs +1/−2
- compiler/GHC/Tc/Utils/Monad.hs +6/−6
- compiler/GHC/Tc/Validity.hs +1/−1
- compiler/GHC/ThToHs.hs +36/−13
- compiler/GHC/Unit/Finder.hs +106/−25
- ghc-lib.cabal +8/−3
- ghc-lib/stage0/lib/llvm-targets +2/−0
- libraries/ghci/GHCi/TH.hs +1/−0
- libraries/template-haskell/Language/Haskell/TH/CodeDo.hs +2/−0
compiler/GHC.hs view
@@ -31,7 +31,10 @@ DynFlags(..), GeneralFlag(..), Severity(..), Backend(..), gopt, GhcMode(..), GhcLink(..), parseDynamicFlags, parseTargetFiles,- getSessionDynFlags, setSessionDynFlags,+ getSessionDynFlags,+ setTopSessionDynFlags,+ setSessionDynFlags,+ setUnitDynFlags, getProgramDynFlags, setProgramDynFlags, getInteractiveDynFlags, setInteractiveDynFlags, interpretPackageEnv,@@ -425,6 +428,7 @@ import System.Environment ( getEnv, getProgName ) import System.Directory import Data.List (isPrefixOf)+import qualified Data.Set as S -- %************************************************************************@@ -632,23 +636,85 @@ -- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags' -- retrieves the program @DynFlags@ (for backwards compatibility). ---- | Updates both the interactive and program DynFlags in a Session.--- This also reads the package database (unless it has already been--- read), and prepares the compilers knowledge about packages. It can--- be called again to load new packages: just add new package flags to--- (packageFlags dflags).-setSessionDynFlags :: GhcMonad m => DynFlags -> m ()+-- This is a compatability function which sets dynflags for the top session+-- as well as the unit.+setSessionDynFlags :: (HasCallStack, GhcMonad m) => DynFlags -> m () setSessionDynFlags dflags0 = do+ hsc_env <- getSession logger <- getLogger+ dflags <- checkNewDynFlags logger dflags0+ let all_uids = hsc_all_home_unit_ids hsc_env+ case S.toList all_uids of+ [uid] -> do+ setUnitDynFlagsNoCheck uid dflags+ modifySession (hscSetActiveUnitId (homeUnitId_ dflags))+ dflags' <- getDynFlags+ setTopSessionDynFlags dflags'+ [] -> panic "nohue"+ _ -> panic "setSessionDynFlags can only be used with a single home unit"+++setUnitDynFlags :: GhcMonad m => UnitId -> DynFlags -> m ()+setUnitDynFlags uid dflags0 = do+ logger <- getLogger dflags1 <- checkNewDynFlags logger dflags0+ setUnitDynFlagsNoCheck uid dflags1++setUnitDynFlagsNoCheck :: GhcMonad m => UnitId -> DynFlags -> m ()+setUnitDynFlagsNoCheck uid dflags1 = do+ logger <- getLogger hsc_env <- getSession- let old_unit_env = hsc_unit_env hsc_env- let cached_unit_dbs = ue_unit_dbs old_unit_env- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs - dflags <- liftIO $ updatePlatformConstants dflags1 mconstants+ let old_hue = ue_findHomeUnitEnv uid (hsc_unit_env hsc_env)+ let cached_unit_dbs = homeUnitEnv_unit_dbs old_hue+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs (hsc_all_home_unit_ids hsc_env)+ updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants + let upd hue =+ hue+ { homeUnitEnv_units = unit_state+ , homeUnitEnv_unit_dbs = Just dbs+ , homeUnitEnv_dflags = updated_dflags+ , homeUnitEnv_home_unit = Just home_unit+ }++ let unit_env = ue_updateHomeUnitEnv upd uid (hsc_unit_env hsc_env)++ let dflags = updated_dflags++ let unit_env0 = unit_env+ { ue_platform = targetPlatform dflags+ , ue_namever = ghcNameVersion dflags+ }++ -- if necessary, change the key for the currently active unit+ -- as the dynflags might have been changed++ -- This function is called on every --make invocation because at the start of+ -- the session there is one fake unit called main which is immediately replaced+ -- after the DynFlags are parsed.+ let !unit_env1 =+ if homeUnitId_ dflags /= uid+ then+ ue_renameUnitId+ uid+ (homeUnitId_ dflags)+ unit_env0+ else unit_env0++ modifySession $ \h -> h{ hsc_unit_env = unit_env1+ }++ invalidateModSummaryCache+++++setTopSessionDynFlags :: GhcMonad m => DynFlags -> m ()+setTopSessionDynFlags dflags = do+ hsc_env <- getSession+ logger <- getLogger+ -- Interpreter interp <- if gopt Opt_ExternalInterpreter dflags then do@@ -685,22 +751,10 @@ return Nothing #endif - let unit_env = UnitEnv- { ue_platform = targetPlatform dflags- , ue_namever = ghcNameVersion dflags- , ue_home_unit = Just home_unit- , ue_hpt = ue_hpt old_unit_env- , ue_eps = ue_eps old_unit_env- , ue_units = unit_state- , ue_unit_dbs = Just dbs- } - modifySession $ \h -> hscSetFlags dflags $+ modifySession $ \h -> hscSetFlags dflags h{ hsc_IC = (hsc_IC h){ ic_dflags = dflags } , hsc_interp = hsc_interp h <|> interp- -- we only update the interpreter if there wasn't- -- already one set up- , hsc_unit_env = unit_env } invalidateModSummaryCache@@ -722,22 +776,35 @@ let changed = packageFlagsChanged dflags_prev dflags0 if changed then do- old_unit_env <- hsc_unit_env <$> getSession- let cached_unit_dbs = ue_unit_dbs old_unit_env- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 cached_unit_dbs+ -- additionally, set checked dflags so we don't lose fixes+ old_unit_env <- ue_setFlags dflags0 . hsc_unit_env <$> getSession - dflags1 <- liftIO $ updatePlatformConstants dflags0 mconstants+ home_unit_graph <- forM (ue_home_unit_graph old_unit_env) $ \homeUnitEnv -> do+ let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv+ dflags = homeUnitEnv_dflags homeUnitEnv+ old_hpt = homeUnitEnv_hpt homeUnitEnv+ home_units = unitEnv_keys (ue_home_unit_graph old_unit_env) + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units++ updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants+ pure HomeUnitEnv+ { homeUnitEnv_units = unit_state+ , homeUnitEnv_unit_dbs = Just dbs+ , homeUnitEnv_dflags = updated_dflags+ , homeUnitEnv_hpt = old_hpt+ , homeUnitEnv_home_unit = Just home_unit+ }++ let dflags1 = homeUnitEnv_dflags $ unitEnv_lookup (ue_currentUnit old_unit_env) home_unit_graph let unit_env = UnitEnv- { ue_platform = targetPlatform dflags1- , ue_namever = ghcNameVersion dflags1- , ue_home_unit = Just home_unit- , ue_hpt = ue_hpt old_unit_env- , ue_eps = ue_eps old_unit_env- , ue_units = unit_state- , ue_unit_dbs = Just dbs+ { ue_platform = targetPlatform dflags1+ , ue_namever = ghcNameVersion dflags1+ , ue_home_unit_graph = home_unit_graph+ , ue_current_unit = ue_currentUnit old_unit_env+ , ue_eps = ue_eps old_unit_env }- modifySession $ \h -> hscSetFlags dflags1 $ h{ hsc_unit_env = unit_env }+ modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env } else modifySession (hscSetFlags dflags0) when invalidate_needed $ invalidateModSummaryCache@@ -828,7 +895,8 @@ parseTargetFiles dflags0 fileish_args = let normal_fileish_paths = map normalise_hyp fileish_args- (srcs, objs) = partition_args normal_fileish_paths [] []+ (srcs, raw_objs) = partition_args normal_fileish_paths [] []+ objs = map (augmentByWorkingDirectory dflags0) raw_objs dflags1 = dflags0 { ldInputs = map (FileOption "") objs ++ ldInputs dflags0 }@@ -1025,7 +1093,7 @@ workingDirectoryChanged :: GhcMonad m => m () workingDirectoryChanged = do hsc_env <- getSession- liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_home_unit hsc_env)+ liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env) -- %************************************************************************@@ -1389,7 +1457,7 @@ getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) getHomeModuleInfo hsc_env mdl =- case lookupHpt (hsc_HPT hsc_env) (moduleName mdl) of+ case lookupHugByModule mdl (hsc_HUG hsc_env) of Nothing -> return Nothing Just hmi -> do let details = hm_details hmi@@ -1637,31 +1705,28 @@ -- using the algorithm that is used for an @import@ declaration. findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module findModule mod_name maybe_pkg = do- pkg_qual <- renamePkgQualM maybe_pkg+ pkg_qual <- renamePkgQualM mod_name maybe_pkg findQualifiedModule pkg_qual mod_name findQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do- let fc = hsc_FC hsc_env- let mhome_unit = ue_home_unit (hsc_unit_env hsc_env)- let units = hsc_units hsc_env- let dflags = hsc_dflags hsc_env- let fopts = initFinderOpts dflags+ let mhome_unit = hsc_home_unit_maybe hsc_env+ let dflags = hsc_dflags hsc_env case pkgqual of- ThisPkg _ -> do- home <- lookupLoadedHomeModule mod_name+ ThisPkg uid -> do+ home <- lookupLoadedHomeModule uid mod_name case home of Just m -> return m Nothing -> liftIO $ do- res <- findImportedModule fc fopts units mhome_unit mod_name pkgqual+ res <- findImportedModule hsc_env mod_name pkgqual case res of Found loc m | notHomeModuleMaybe mhome_unit m -> return m | otherwise -> modNotLoadedError dflags m loc err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err _ -> liftIO $ do- res <- findImportedModule fc fopts units mhome_unit mod_name pkgqual+ res <- findImportedModule hsc_env mod_name pkgqual case res of Found _ m -> return m err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err@@ -1673,11 +1738,11 @@ quotes (ppr (moduleName m)) <+> parens (text (expectJust "modNotLoadedError" (ml_hs_file loc))) -renamePkgQualM :: GhcMonad m => Maybe FastString -> m PkgQual-renamePkgQualM p = withSession $ \hsc_env -> pure (renamePkgQual (hsc_unit_env hsc_env) p)+renamePkgQualM :: GhcMonad m => ModuleName -> Maybe FastString -> m PkgQual+renamePkgQualM mn p = withSession $ \hsc_env -> pure (renamePkgQual (hsc_unit_env hsc_env) mn p) -renameRawPkgQualM :: GhcMonad m => RawPkgQual -> m PkgQual-renameRawPkgQualM p = withSession $ \hsc_env -> pure (renameRawPkgQual (hsc_unit_env hsc_env) p)+renameRawPkgQualM :: GhcMonad m => ModuleName -> RawPkgQual -> m PkgQual+renameRawPkgQualM mn p = withSession $ \hsc_env -> pure (renameRawPkgQual (hsc_unit_env hsc_env) mn p) -- | Like 'findModule', but differs slightly when the module refers to -- a source file, and the file has not been loaded via 'load'. In@@ -1688,12 +1753,12 @@ -- lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module lookupModule mod_name maybe_pkg = do- pkgqual <- renamePkgQualM maybe_pkg+ pkgqual <- renamePkgQualM mod_name maybe_pkg lookupQualifiedModule pkgqual mod_name lookupQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do- home <- lookupLoadedHomeModule mod_name+ home <- lookupLoadedHomeModule (homeUnitId $ hsc_home_unit hsc_env) mod_name case home of Just m -> return m Nothing -> liftIO $ do@@ -1707,9 +1772,9 @@ err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err lookupQualifiedModule pkgqual mod_name = findQualifiedModule pkgqual mod_name -lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module)-lookupLoadedHomeModule mod_name = withSession $ \hsc_env ->- case lookupHpt (hsc_HPT hsc_env) mod_name of+lookupLoadedHomeModule :: GhcMonad m => UnitId -> ModuleName -> m (Maybe Module)+lookupLoadedHomeModule uid mod_name = withSession $ \hsc_env ->+ case lookupHug (hsc_HUG hsc_env) uid mod_name of Just mod_info -> return (Just (mi_module (hm_iface mod_info))) _not_a_home_module -> return Nothing
+ compiler/GHC/Cmm/Config.hs view
@@ -0,0 +1,32 @@+-- | Cmm compilation configuration++{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module GHC.Cmm.Config+ ( CmmConfig(..)+ , cmmPlatform+ ) where++import GHC.Prelude++import GHC.Platform+import GHC.Platform.Profile+++data CmmConfig = CmmConfig+ { cmmProfile :: !Profile -- ^ Target Profile+ , cmmOptControlFlow :: !Bool -- ^ Optimize Cmm Control Flow or not+ , cmmDoLinting :: !Bool -- ^ Do Cmm Linting Optimization or not+ , cmmOptElimCommonBlks :: !Bool -- ^ Eliminate common blocks or not+ , cmmOptSink :: !Bool -- ^ Perform sink after stack layout or not+ , cmmGenStackUnwindInstr :: !Bool -- ^ Generate stack unwinding instructions (for debugging)+ , cmmExternalDynamicRefs :: !Bool -- ^ Generate code to link against dynamic libraries+ , cmmDoCmmSwitchPlans :: !Bool -- ^ Should the Cmm pass replace Stg switch statements+ , cmmSplitProcPoints :: !Bool -- ^ Should Cmm split proc points or not+ }++-- | retrieve the target Cmm platform+cmmPlatform :: CmmConfig -> Platform+cmmPlatform = profilePlatform . cmmProfile+
compiler/GHC/Cmm/Dataflow.hs view
@@ -82,6 +82,11 @@ type TransferFun f = CmmBlock -> FactBase f -> FactBase f +-- | `TransferFun` abstracted over `n` (the node type)+type TransferFun' (n :: Extensibility -> Extensibility -> Type) f =+ Block n C C -> FactBase f -> FactBase f++ -- | Function for rewrtiting and analysis combined. To be used with -- @rewriteCmm@. --@@ -90,20 +95,26 @@ -- to the particular monads through SPECIALIZE). type RewriteFun f = CmmBlock -> FactBase f -> UniqSM (CmmBlock, FactBase f) +-- | `RewriteFun` abstracted over `n` (the node type)+type RewriteFun' (n :: Extensibility -> Extensibility -> Type) f =+ Block n C C -> FactBase f -> UniqSM (Block n C C, FactBase f)+ analyzeCmmBwd, analyzeCmmFwd- :: DataflowLattice f- -> TransferFun f- -> CmmGraph+ :: (NonLocal node)+ => DataflowLattice f+ -> TransferFun' node f+ -> GenCmmGraph node -> FactBase f -> FactBase f analyzeCmmBwd = analyzeCmm Bwd analyzeCmmFwd = analyzeCmm Fwd analyzeCmm- :: Direction+ :: (NonLocal node)+ => Direction -> DataflowLattice f- -> TransferFun f- -> CmmGraph+ -> TransferFun' node f+ -> GenCmmGraph node -> FactBase f -> FactBase f analyzeCmm dir lattice transfer cmmGraph initFact =@@ -117,12 +128,13 @@ -- Fixpoint algorithm. fixpointAnalysis- :: forall f.- Direction+ :: forall f node.+ (NonLocal node)+ => Direction -> DataflowLattice f- -> TransferFun f+ -> TransferFun' node f -> Label- -> LabelMap CmmBlock+ -> LabelMap (Block node C C) -> FactBase f -> FactBase f fixpointAnalysis direction lattice do_block entry blockmap = loop start@@ -155,20 +167,22 @@ loop _ !fbase1 = fbase1 rewriteCmmBwd- :: DataflowLattice f- -> RewriteFun f- -> CmmGraph+ :: (NonLocal node)+ => DataflowLattice f+ -> RewriteFun' node f+ -> GenCmmGraph node -> FactBase f- -> UniqSM (CmmGraph, FactBase f)+ -> UniqSM (GenCmmGraph node, FactBase f) rewriteCmmBwd = rewriteCmm Bwd rewriteCmm- :: Direction+ :: (NonLocal node)+ => Direction -> DataflowLattice f- -> RewriteFun f- -> CmmGraph+ -> RewriteFun' node f+ -> GenCmmGraph node -> FactBase f- -> UniqSM (CmmGraph, FactBase f)+ -> UniqSM (GenCmmGraph node, FactBase f) rewriteCmm dir lattice rwFun cmmGraph initFact = {-# SCC rewriteCmm #-} do let entry = g_entry cmmGraph hooplGraph = g_graph cmmGraph@@ -180,14 +194,15 @@ return (cmmGraph {g_graph = GMany NothingO blockMap2 NothingO}, facts) fixpointRewrite- :: forall f.- Direction+ :: forall f node.+ NonLocal node+ => Direction -> DataflowLattice f- -> RewriteFun f+ -> RewriteFun' node f -> Label- -> LabelMap CmmBlock+ -> LabelMap (Block node C C) -> FactBase f- -> UniqSM (LabelMap CmmBlock, FactBase f)+ -> UniqSM (LabelMap (Block node C C), FactBase f) fixpointRewrite dir lattice do_block entry blockmap = loop start blockmap where -- Sorting the blocks helps to minimize the number of times we need to@@ -204,9 +219,9 @@ loop :: IntHeap -- ^ Worklist, i.e., blocks to process- -> LabelMap CmmBlock -- ^ Rewritten blocks.+ -> LabelMap (Block node C C) -- ^ Rewritten blocks. -> FactBase f -- ^ Current facts.- -> UniqSM (LabelMap CmmBlock, FactBase f)+ -> UniqSM (LabelMap (Block node C C), FactBase f) loop todo !blocks1 !fbase1 | Just (index, todo1) <- IntSet.minView todo = do -- Note that we use the *original* block here. This is important.@@ -309,7 +324,7 @@ -- * for a backward analysis we need to re-analyze all the predecessors, but -- * for a forward analysis, we only need to re-analyze the current block -- (and that will in turn propagate facts into its successors).-mkDepBlocks :: Direction -> [CmmBlock] -> LabelMap IntSet+mkDepBlocks :: NonLocal node => Direction -> [Block node C C] -> LabelMap IntSet mkDepBlocks Fwd blocks = go blocks 0 mapEmpty where go [] !_ !dep_map = dep_map@@ -396,7 +411,7 @@ -- | Folds backward over all nodes of an open-open block. -- Strict in the accumulator.-foldNodesBwdOO :: (CmmNode O O -> f -> f) -> Block CmmNode O O -> f -> f+foldNodesBwdOO :: (node O O -> f -> f) -> Block node O O -> f -> f foldNodesBwdOO funOO = go where go (BCat b1 b2) f = go b1 $! go b2 f@@ -411,11 +426,11 @@ -- dataflow facts). -- Strict in both accumulated parts. foldRewriteNodesBwdOO- :: forall f.- (CmmNode O O -> f -> UniqSM (Block CmmNode O O, f))- -> Block CmmNode O O+ :: forall f node.+ (node O O -> f -> UniqSM (Block node O O, f))+ -> Block node O O -> f- -> UniqSM (Block CmmNode O O, f)+ -> UniqSM (Block node O O, f) foldRewriteNodesBwdOO rewriteOO initBlock initFacts = go initBlock initFacts where go (BCons node1 block1) !fact1 = (rewriteOO node1 `comp` go block1) fact1
compiler/GHC/Cmm/Info/Build.hs view
@@ -23,6 +23,7 @@ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Cmm.BlockId+import GHC.Cmm.Config import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label@@ -33,7 +34,6 @@ import GHC.Cmm.CLabel import GHC.Cmm import GHC.Cmm.Utils-import GHC.Driver.Session import GHC.Data.Maybe import GHC.Utils.Outputable import GHC.Utils.Panic@@ -41,7 +41,6 @@ import GHC.Types.Unique.Supply import GHC.Types.CostCentre import GHC.StgToCmm.Heap-import GHC.Driver.Config.CmmToAsm import Control.Monad import Data.Map.Strict (Map)@@ -793,16 +792,16 @@ -- declarations to the ModuleSRTInfo. -- doSRTs- :: DynFlags+ :: CmmConfig -> ModuleSRTInfo -> [(CAFEnv, [CmmDecl])] -> [(CAFSet, CmmDecl)] -> IO (ModuleSRTInfo, [CmmDeclSRTs]) -doSRTs dflags moduleSRTInfo procs data_ = do+doSRTs cfg moduleSRTInfo procs data_ = do us <- mkSplitUniqSupply 'u' - let profile = targetProfile dflags+ let profile = cmmProfile cfg -- Ignore the original grouping of decls, and combine all the -- CAFEnvs into a single CAFEnv.@@ -827,7 +826,7 @@ decls = map snd data_ ++ concat procss staticFuns = mapFromList (getStaticFuns decls) - platform = targetPlatform dflags+ platform = cmmPlatform cfg -- Put the decls in dependency order. Why? So that we can implement -- [Inline] and [Filter]. If we need to refer to an SRT that has@@ -860,9 +859,9 @@ (result, moduleSRTInfo') = initUs_ us $ flip runStateT moduleSRTInfo $ do- nonCAFs <- mapM (doSCC dflags staticFuns static_data) sccs+ nonCAFs <- mapM (doSCC cfg staticFuns static_data) sccs cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) ->- oneSRT dflags staticFuns [BlockLabel l] [cafLbl]+ oneSRT cfg staticFuns [BlockLabel l] [cafLbl] True{-is a CAF-} cafs static_data return (nonCAFs ++ cAFs) @@ -904,7 +903,7 @@ -- | Build the SRT for a strongly-connected component of blocks doSCC- :: DynFlags+ :: CmmConfig -> LabelMap CLabel -- which blocks are static function entry points -> Set CLabel -- static data -> SCC (SomeLabel, CAFLabel, Set CAFLabel)@@ -915,14 +914,14 @@ , Bool -- Whether the group has CAF references ) -doSCC dflags staticFuns static_data (AcyclicSCC (l, cafLbl, cafs)) =- oneSRT dflags staticFuns [l] [cafLbl] False cafs static_data+doSCC cfg staticFuns static_data (AcyclicSCC (l, cafLbl, cafs)) =+ oneSRT cfg staticFuns [l] [cafLbl] False cafs static_data -doSCC dflags staticFuns static_data (CyclicSCC nodes) = do+doSCC cfg staticFuns static_data (CyclicSCC nodes) = do -- build a single SRT for the whole cycle, see Note [recursive SRTs] let (lbls, caf_lbls, cafsets) = unzip3 nodes cafs = Set.unions cafsets- oneSRT dflags staticFuns lbls caf_lbls False cafs static_data+ oneSRT cfg staticFuns lbls caf_lbls False cafs static_data {- Note [recursive SRTs]@@ -951,7 +950,7 @@ -- | Build an SRT for a set of blocks oneSRT- :: DynFlags+ :: CmmConfig -> LabelMap CLabel -- which blocks are static function entry points -> [SomeLabel] -- blocks in this set -> [CAFLabel] -- labels for those blocks@@ -965,15 +964,14 @@ , Bool -- Whether the group has CAF references ) -oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do+oneSRT cfg staticFuns lbls caf_lbls isCAF cafs static_data = do topSRT <- get let this_mod = thisModule topSRT- config = initNCGConfig dflags this_mod- profile = targetProfile dflags+ profile = cmmProfile cfg platform = profilePlatform profile- srtMap = moduleSRTMap topSRT+ srtMap = moduleSRTMap topSRT blockids = getBlockLabels lbls @@ -1070,7 +1068,7 @@ -- when dynamic linking is used we cannot guarantee that the offset -- between the SRT and the info table will fit in the offset field. -- Consequently we build a singleton SRT in this case.- not (labelDynamic config lbl)+ not (labelDynamic this_mod platform (cmmExternalDynamicRefs cfg) lbl) -- MachO relocations can't express offsets between compilation units at -- all, so we are always forced to build a singleton SRT in this case.
compiler/GHC/Cmm/LayoutStack.hs view
@@ -15,6 +15,7 @@ import GHC.Cmm import GHC.Cmm.Info import GHC.Cmm.BlockId+import GHC.Cmm.Config import GHC.Cmm.Utils import GHC.Cmm.Graph import GHC.Cmm.Liveness@@ -30,7 +31,6 @@ import GHC.Types.Unique.FM import GHC.Utils.Misc -import GHC.Driver.Session import GHC.Utils.Outputable hiding ( isEmpty ) import GHC.Utils.Panic import qualified Data.Set as Set@@ -235,21 +235,21 @@ text "sm_regs = " <> pprUFM sm_regs ppr -cmmLayoutStack :: DynFlags -> ProcPointSet -> ByteOff -> CmmGraph+cmmLayoutStack :: CmmConfig -> ProcPointSet -> ByteOff -> CmmGraph -> UniqSM (CmmGraph, LabelMap StackMap)-cmmLayoutStack dflags procpoints entry_args+cmmLayoutStack cfg procpoints entry_args graph@(CmmGraph { g_entry = entry }) = do -- We need liveness info. Dead assignments are removed later -- by the sinking pass. let liveness = cmmLocalLiveness platform graph- blocks = revPostorder graph- profile = targetProfile dflags+ blocks = revPostorder graph+ profile = cmmProfile cfg platform = profilePlatform profile (final_stackmaps, _final_high_sp, new_blocks) <- mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) ->- layout dflags procpoints liveness entry entry_args+ layout cfg procpoints liveness entry entry_args rec_stackmaps rec_high_sp blocks blocks_with_reloads <-@@ -261,7 +261,7 @@ -- Pass 1 -- ----------------------------------------------------------------------------- -layout :: DynFlags+layout :: CmmConfig -> LabelSet -- proc points -> LabelMap CmmLocalLive -- liveness -> BlockId -- entry@@ -278,7 +278,7 @@ , [CmmBlock] -- [out] new blocks ) -layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high blocks+layout cfg procpoints liveness entry entry_args final_stackmaps final_sp_high blocks = go blocks init_stackmap entry_args [] where (updfr, cont_info) = collectContInfo blocks@@ -311,7 +311,7 @@ -- each of the successor blocks. See handleLastNode for -- details. (middle1, sp_off, last1, fixup_blocks, out)- <- handleLastNode dflags procpoints liveness cont_info+ <- handleLastNode cfg procpoints liveness cont_info acc_stackmaps stack1 tscope middle0 last0 -- (c) Manifest Sp: run over the nodes in the block and replace@@ -326,7 +326,7 @@ let middle_pre = blockToList $ foldl' blockSnoc middle0 middle1 let final_blocks =- manifestSp dflags final_stackmaps stack0 sp0 final_sp_high+ manifestSp cfg final_stackmaps stack0 sp0 final_sp_high entry0 middle_pre sp_off last1 fixup_blocks let acc_stackmaps' = mapUnion acc_stackmaps out@@ -433,7 +433,7 @@ -- extra code that goes *after* the Sp adjustment. handleLastNode- :: DynFlags -> ProcPointSet -> LabelMap CmmLocalLive -> LabelMap ByteOff+ :: CmmConfig -> ProcPointSet -> LabelMap CmmLocalLive -> LabelMap ByteOff -> LabelMap StackMap -> StackMap -> CmmTickScope -> Block CmmNode O O -> CmmNode O C@@ -445,7 +445,7 @@ , LabelMap StackMap -- stackmaps for the continuations ) -handleLastNode dflags procpoints liveness cont_info stackmaps+handleLastNode cfg procpoints liveness cont_info stackmaps stack0@StackMap { sm_sp = sp0 } tscp middle last = case last of -- At each return / tail call,@@ -467,7 +467,7 @@ CmmCondBranch {} -> handleBranches CmmSwitch {} -> handleBranches where- platform = targetPlatform dflags+ platform = cmmPlatform cfg -- Calls and ForeignCalls are handled the same way: lastCall :: BlockId -> ByteOff -> ByteOff -> ByteOff -> ( [CmmNode O O]@@ -544,7 +544,7 @@ | Just stack2 <- mapLookup l stackmaps = do let assigs = fixupStack stack0 stack2- (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs+ (tmp_lbl, block) <- makeFixupBlock cfg sp0 l stack2 tscp assigs return (l, tmp_lbl, stack2, block) -- (b) if the successor is a proc point, save everything@@ -555,7 +555,7 @@ (stack2, assigs) = setupStackFrame platform l liveness (sm_ret_off stack0) cont_args stack0- (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs+ (tmp_lbl, block) <- makeFixupBlock cfg sp0 l stack2 tscp assigs return (l, tmp_lbl, stack2, block) -- (c) otherwise, the current StackMap is the StackMap for@@ -569,16 +569,16 @@ is_live (r,_) = r `elemRegSet` live -makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap+makeFixupBlock :: CmmConfig -> ByteOff -> Label -> StackMap -> CmmTickScope -> [CmmNode O O] -> UniqSM (Label, [CmmBlock])-makeFixupBlock dflags sp0 l stack tscope assigs+makeFixupBlock cfg sp0 l stack tscope assigs | null assigs && sp0 == sm_sp stack = return (l, []) | otherwise = do tmp_lbl <- newBlockId let sp_off = sp0 - sm_sp stack block = blockJoin (CmmEntry tmp_lbl tscope)- ( maybeAddSpAdj dflags sp0 sp_off+ ( maybeAddSpAdj cfg sp0 sp_off $ blockFromList assigs ) (CmmBranch l) return (tmp_lbl, [block])@@ -822,7 +822,7 @@ -- middle_post, because the Sp adjustment intervenes. -- manifestSp- :: DynFlags+ :: CmmConfig -> LabelMap StackMap -- StackMaps for other blocks -> StackMap -- StackMap for this block -> ByteOff -- Sp on entry to the block@@ -834,18 +834,18 @@ -> [CmmBlock] -- new blocks -> [CmmBlock] -- final blocks with Sp manifest -manifestSp dflags stackmaps stack0 sp0 sp_high+manifestSp cfg stackmaps stack0 sp0 sp_high first middle_pre sp_off last fixup_blocks = final_block : fixup_blocks' where area_off = getAreaOff stackmaps- platform = targetPlatform dflags+ platform = cmmPlatform cfg adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x adj_pre_sp = mapExpDeep (areaToSp platform sp0 sp_high area_off) adj_post_sp = mapExpDeep (areaToSp platform (sp0 - sp_off) sp_high area_off) - final_middle = maybeAddSpAdj dflags sp0 sp_off+ final_middle = maybeAddSpAdj cfg sp0 sp_off . blockFromList . map adj_pre_sp . elimStackStores stack0 stackmaps area_off@@ -865,11 +865,12 @@ maybeAddSpAdj- :: DynFlags -> ByteOff -> ByteOff -> Block CmmNode O O -> Block CmmNode O O-maybeAddSpAdj dflags sp0 sp_off block =+ :: CmmConfig -> ByteOff -> ByteOff -> Block CmmNode O O -> Block CmmNode O O+maybeAddSpAdj cfg sp0 sp_off block = add_initial_unwind $ add_adj_unwind $ adj block where- platform = targetPlatform dflags+ platform = cmmPlatform cfg+ do_stk_unwinding_gen = cmmGenStackUnwindInstr cfg adj block | sp_off /= 0 = block `blockSnoc` CmmAssign spReg (cmmOffset platform spExpr sp_off)@@ -877,7 +878,7 @@ -- Add unwind pseudo-instruction at the beginning of each block to -- document Sp level for debugging add_initial_unwind block- | debugLevel dflags > 0+ | do_stk_unwinding_gen = CmmUnwind [(Sp, Just sp_unwind)] `blockCons` block | otherwise = block@@ -886,7 +887,7 @@ -- Add unwind pseudo-instruction right after the Sp adjustment -- if there is one. add_adj_unwind block- | debugLevel dflags > 0+ | do_stk_unwinding_gen , sp_off /= 0 = block `blockSnoc` CmmUnwind [(Sp, Just sp_unwind)] | otherwise
compiler/GHC/Cmm/Lint.hs view
@@ -98,6 +98,7 @@ lintCmmExpr expr@(CmmMachOp op args) = do platform <- getPlatform tys <- mapM lintCmmExpr args+ lintShiftOp op (zip args tys) if map (typeWidth . cmmExprType platform) args == machOpArgReps platform op then cmmCheckMachOp op args tys else cmmLintMachOpErr expr (map (cmmExprType platform) args) (machOpArgReps platform op)@@ -109,6 +110,22 @@ lintCmmExpr expr = do platform <- getPlatform return (cmmExprType platform expr)++-- | Check for obviously out-of-bounds shift operations+lintShiftOp :: MachOp -> [(CmmExpr, CmmType)] -> CmmLint ()+lintShiftOp op [(_, arg_ty), (CmmLit (CmmInt n _), _)]+ | isShiftOp op+ , n >= fromIntegral (widthInBits (typeWidth arg_ty))+ = cmmLintErr (text "Shift operation" <+> pprMachOp op+ <+> text "has out-of-range offset" <+> ppr n+ <> text ". This will result in undefined behavior")+lintShiftOp _ _ = return ()++isShiftOp :: MachOp -> Bool+isShiftOp (MO_Shl _) = True+isShiftOp (MO_U_Shr _) = True+isShiftOp (MO_S_Shr _) = True+isShiftOp _ = False -- Check for some common byte/word mismatches (eg. Sp + 1) cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
compiler/GHC/Cmm/Opt.hs view
@@ -72,6 +72,16 @@ _ -> panic $ "cmmMachOpFoldM: unknown unary op: " ++ show op +-- Eliminate shifts that are wider than the shiftee+cmmMachOpFoldM _ op [_shiftee, CmmLit (CmmInt shift _)]+ | Just width <- isShift op+ , shift >= fromIntegral (widthInBits width)+ = Just $! CmmLit (CmmInt 0 width)+ where+ isShift (MO_Shl w) = Just w+ isShift (MO_U_Shr w) = Just w+ isShift (MO_S_Shr w) = Just w+ isShift _ = Nothing -- Eliminate conversion NOPs cmmMachOpFoldM _ (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = Just x@@ -130,16 +140,16 @@ MO_Mul r -> Just $! CmmLit (CmmInt (x * y) r) MO_U_Quot r | y /= 0 -> Just $! CmmLit (CmmInt (x_u `quot` y_u) r) MO_U_Rem r | y /= 0 -> Just $! CmmLit (CmmInt (x_u `rem` y_u) r)- MO_S_Quot r | y /= 0 -> Just $! CmmLit (CmmInt (x `quot` y) r)- MO_S_Rem r | y /= 0 -> Just $! CmmLit (CmmInt (x `rem` y) r)+ MO_S_Quot r | y /= 0 -> Just $! CmmLit (CmmInt (x_s `quot` y_s) r)+ MO_S_Rem r | y /= 0 -> Just $! CmmLit (CmmInt (x_s `rem` y_s) r) MO_And r -> Just $! CmmLit (CmmInt (x .&. y) r) MO_Or r -> Just $! CmmLit (CmmInt (x .|. y) r) MO_Xor r -> Just $! CmmLit (CmmInt (x `xor` y) r) - MO_Shl r -> Just $! CmmLit (CmmInt (x `shiftL` fromIntegral y) r)+ MO_Shl r -> Just $! CmmLit (CmmInt (x `shiftL` fromIntegral y) r) MO_U_Shr r -> Just $! CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r)- MO_S_Shr r -> Just $! CmmLit (CmmInt (x `shiftR` fromIntegral y) r)+ MO_S_Shr r -> Just $! CmmLit (CmmInt (x_s `shiftR` fromIntegral y) r) _ -> Nothing
compiler/GHC/Cmm/Pipeline.hs view
@@ -10,19 +10,20 @@ import GHC.Prelude import GHC.Cmm-import GHC.Cmm.Lint-import GHC.Cmm.Info.Build-import GHC.Cmm.CommonBlockElim-import GHC.Cmm.Switch.Implement-import GHC.Cmm.ProcPoint+import GHC.Cmm.Config import GHC.Cmm.ContFlowOpt+import GHC.Cmm.CommonBlockElim+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Info.Build+import GHC.Cmm.Lint import GHC.Cmm.LayoutStack+import GHC.Cmm.ProcPoint import GHC.Cmm.Sink-import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Switch.Implement import GHC.Types.Unique.Supply import GHC.Driver.Session-import GHC.Driver.Backend+import GHC.Driver.Config.Cmm import GHC.Utils.Error import GHC.Utils.Logger import GHC.Driver.Env@@ -43,23 +44,23 @@ -> IO (ModuleSRTInfo, CmmGroupSRTs) -- Output CPS transformed C-- cmmPipeline hsc_env srtInfo prog = do- let logger = hsc_logger hsc_env- let dflags = hsc_dflags hsc_env- let forceRes (info, group) = info `seq` foldr (\decl r -> decl `seq` r) () group- let platform = targetPlatform dflags+ let logger = hsc_logger hsc_env+ let cmmConfig = initCmmConfig (hsc_dflags hsc_env)+ let forceRes (info, group) = info `seq` foldr seq () group+ let platform = cmmPlatform cmmConfig withTimingSilent logger (text "Cmm pipeline") forceRes $ do- tops <- {-# SCC "tops" #-} mapM (cpsTop logger platform dflags) prog+ tops <- {-# SCC "tops" #-} mapM (cpsTop logger platform cmmConfig) prog let (procs, data_) = partitionEithers tops- (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo procs data_+ (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs cmmConfig srtInfo procs data_ dumpWith logger Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms) return (srtInfo, cmms) -cpsTop :: Logger -> Platform -> DynFlags -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl))+cpsTop :: Logger -> Platform -> CmmConfig -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl)) cpsTop _logger platform _ p@(CmmData _ statics) = return (Right (cafAnalData platform statics, p))-cpsTop logger platform dflags proc =+cpsTop logger platform cfg proc = do ----------- Control-flow optimisations ---------------------------------- @@ -76,15 +77,17 @@ ----------- Eliminate common blocks ------------------------------------- g <- {-# SCC "elimCommonBlocks" #-}- condPass Opt_CmmElimCommonBlocks elimCommonBlocks g+ condPass (cmmOptElimCommonBlks cfg) elimCommonBlocks g Opt_D_dump_cmm_cbe "Post common block elimination" -- Any work storing block Labels must be performed _after_ -- elimCommonBlocks ----------- Implement switches ------------------------------------------- g <- {-# SCC "createSwitchPlans" #-}- runUniqSM $ cmmImplementSwitchPlans (backend dflags) platform g+ g <- if cmmDoCmmSwitchPlans cfg+ then {-# SCC "createSwitchPlans" #-}+ runUniqSM $ cmmImplementSwitchPlans platform g+ else pure g dump Opt_D_dump_cmm_switch "Post switch plan" g ----------- Proc points -------------------------------------------------@@ -106,13 +109,13 @@ (g, stackmaps) <- {-# SCC "layoutStack" #-} if do_layout- then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g+ then runUniqSM $ cmmLayoutStack cfg proc_points entry_off g else return (g, mapEmpty) dump Opt_D_dump_cmm_sp "Layout Stack" g ----------- Sink and inline assignments -------------------------------- g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]- condPass Opt_CmmSink (cmmSink platform) g+ condPass (cmmOptSink cfg) (cmmSink platform) g Opt_D_dump_cmm_sink "Sink assignments" ------------- CAF analysis ----------------------------------------------@@ -142,7 +145,7 @@ ----------- Control-flow optimisations ----------------------------- g <- {-# SCC "cmmCfgOpts(2)" #-}- return $ if gopt Opt_CmmControlFlow dflags+ return $ if cmmOptControlFlow cfg then map (cmmCfgOptsProc splitting_proc_points) g else g g <- return (map removeUnreachableBlocksProc g)@@ -151,13 +154,13 @@ return (Left (cafEnv, g)) - where dump = dumpGraph logger platform dflags+ where dump = dumpGraph logger platform (cmmDoLinting cfg) dumps flag name = mapM_ (dumpWith logger flag name FormatCMM . pdoc platform) - condPass flag pass g dumpflag dumpname =- if gopt flag dflags+ condPass do_opt pass g dumpflag dumpname =+ if do_opt then do g <- return $ pass g dump dumpflag dumpname g@@ -168,14 +171,7 @@ -- tablesNextToCode is off. The latter is because we have no -- label to put on info tables for basic blocks that are not -- the entry point.- splitting_proc_points = backend dflags /= NCG- || not (platformTablesNextToCode platform)- || -- Note [inconsistent-pic-reg]- usingInconsistentPicReg- usingInconsistentPicReg- = case (platformArch platform, platformOS platform, positionIndependent dflags)- of (ArchX86, OSDarwin, pic) -> pic- _ -> False+ splitting_proc_points = cmmSplitProcPoints cfg -- Note [Sinking after stack layout] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -347,9 +343,9 @@ return (initUs_ us m) -dumpGraph :: Logger -> Platform -> DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()-dumpGraph logger platform dflags flag name g = do- when (gopt Opt_DoCmmLinting dflags) $ do_lint g+dumpGraph :: Logger -> Platform -> Bool -> DumpFlag -> String -> CmmGraph -> IO ()+dumpGraph logger platform do_linting flag name g = do+ when do_linting $ do_lint g dumpWith logger flag name FormatCMM (pdoc platform g) where do_lint g = case cmmLintGraph platform g of
compiler/GHC/Cmm/Sink.hs view
@@ -443,7 +443,7 @@ -- ----------------------------------------------------------------------------- -- Try to inline assignments into a node.--- This also does constant folding for primpops, since+-- This also does constant folding for primops, since -- inlining opens up opportunities for doing so. tryToInline
compiler/GHC/Cmm/Switch/Implement.hs view
@@ -6,7 +6,6 @@ import GHC.Prelude -import GHC.Driver.Backend import GHC.Platform import GHC.Cmm.Dataflow.Block import GHC.Cmm.BlockId@@ -32,11 +31,10 @@ -- | Traverses the 'CmmGraph', making sure that 'CmmSwitch' are suitable for -- code generation.-cmmImplementSwitchPlans :: Backend -> Platform -> CmmGraph -> UniqSM CmmGraph-cmmImplementSwitchPlans backend platform g+cmmImplementSwitchPlans :: Platform -> CmmGraph -> UniqSM CmmGraph+cmmImplementSwitchPlans platform g = -- Switch generation done by backend (LLVM/C)- | backendSupportsSwitch backend = return g- | otherwise = do+ do blocks' <- concatMapM (visitSwitches platform) (toBlockList g) return $ ofBlockList (g_entry g) blocks'
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs view
@@ -14,6 +14,8 @@ -- NCG stuff: import GHC.Prelude hiding (EQ) +import Data.Word+ import GHC.Platform.Regs import GHC.CmmToAsm.AArch64.Instr import GHC.CmmToAsm.AArch64.Regs@@ -49,8 +51,7 @@ import GHC.Data.OrdList import GHC.Utils.Outputable -import Control.Monad ( mapAndUnzipM, when, foldM )-import Data.Word+import Control.Monad ( mapAndUnzipM, foldM ) import Data.Maybe import GHC.Float @@ -396,13 +397,60 @@ litToImm' :: CmmLit -> NatM (Operand, InstrBlock) litToImm' lit = return (OpImm (litToImm lit), nilOL) - getRegister :: CmmExpr -> NatM Register getRegister e = do config <- getConfig getRegister' config (ncgPlatform config) e +-- | The register width to be used for an operation on the given width+-- operand.+opRegWidth :: Width -> Width+opRegWidth W64 = W64 -- x+opRegWidth W32 = W32 -- w+opRegWidth W16 = W32 -- w+opRegWidth W8 = W32 -- w+opRegWidth w = pprPanic "opRegWidth" (text "Unsupported width" <+> ppr w)++-- Note [Signed arithmetic on AArch64]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Handling signed arithmetic on sub-word-size values on AArch64 is a bit+-- tricky as Cmm's type system does not capture signedness. While 32-bit values+-- are fairly easy to handle due to AArch64's 32-bit instruction variants+-- (denoted by use of %wN registers), 16- and 8-bit values require quite some+-- care.+--+-- We handle 16-and 8-bit values by using the 32-bit operations and+-- sign-/zero-extending operands and truncate results as necessary. For+-- simplicity we maintain the invariant that a register containing a+-- sub-word-size value always contains the zero-extended form of that value+-- in between operations.+--+-- For instance, consider the program,+--+-- test(bits64 buffer)+-- bits8 a = bits8[buffer];+-- bits8 b = %mul(a, 42);+-- bits8 c = %not(b);+-- bits8 d = %shrl(c, 4::bits8);+-- return (d);+-- }+--+-- This program begins by loading `a` from memory, for which we use a+-- zero-extended byte-size load. We next sign-extend `a` to 32-bits, and use a+-- 32-bit multiplication to compute `b`, and truncate the result back down to+-- 8-bits.+--+-- Next we compute `c`: The `%not` requires no extension of its operands, but+-- we must still truncate the result back down to 8-bits. Finally the `%shrl`+-- requires no extension and no truncate since we can assume that+-- `c` is zero-extended.+--+-- TODO:+-- Don't use Width in Operands+-- Instructions should rather carry a RegWidth+-- -- Note [Handling PIC on AArch64]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- AArch64 does not have a special PIC register, the general approach is to -- simply go through the GOT, and there is assembly support for this: --@@ -451,9 +499,9 @@ return (Any (intFormat W16) (\dst -> unitOL $ annExpr expr (MOV (OpReg W16 dst) (OpImm (ImmInteger (narrowU W16 i)))))) CmmInt i W8 -> do- return (Any (intFormat W8) (\dst -> unitOL $ annExpr expr (MOV (OpReg W8 dst) (OpImm (ImmInteger (narrowS W8 i))))))+ return (Any (intFormat W8) (\dst -> unitOL $ annExpr expr (MOV (OpReg W8 dst) (OpImm (ImmInteger (narrowU W8 i)))))) CmmInt i W16 -> do- return (Any (intFormat W16) (\dst -> unitOL $ annExpr expr (MOV (OpReg W16 dst) (OpImm (ImmInteger (narrowS W16 i))))))+ return (Any (intFormat W16) (\dst -> unitOL $ annExpr expr (MOV (OpReg W16 dst) (OpImm (ImmInteger (narrowU W16 i)))))) -- We need to be careful to not shorten this for negative literals. -- Those need the upper bits set. We'd either have to explicitly sign@@ -550,7 +598,7 @@ CmmBlock _ -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr) CmmHighStackMark -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr) CmmLoad mem rep -> do- Amode addr addr_code <- getAmode plat mem+ Amode addr addr_code <- getAmode plat (typeWidth rep) mem let format = cmmTypeFormat rep return (Any format (\dst -> addr_code `snocOL` LDR format (OpReg (formatToWidth format) dst) (OpAddr addr))) CmmStackSlot _ _@@ -577,9 +625,13 @@ CmmMachOp op [e] -> do (reg, _format, code) <- getSomeReg e case op of- MO_Not w -> return $ Any (intFormat w) (\dst -> code `snocOL` MVN (OpReg w dst) (OpReg w reg))+ MO_Not w -> return $ Any (intFormat w) $ \dst ->+ let w' = opRegWidth w+ in code `snocOL`+ MVN (OpReg w' dst) (OpReg w' reg) `appOL`+ truncateReg w' w dst -- See Note [Signed arithmetic on AArch64] - MO_S_Neg w -> return $ Any (intFormat w) (\dst -> code `snocOL` NEG (OpReg w dst) (OpReg w reg))+ MO_S_Neg w -> negate code w reg MO_F_Neg w -> return $ Any (floatFormat w) (\dst -> code `snocOL` NEG (OpReg w dst) (OpReg w reg)) MO_SF_Conv from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` SCVTF (OpReg to dst) (OpReg from reg)) -- (Signed ConVerT Float)@@ -589,20 +641,41 @@ -- Note, UBFM and SBFM expect source and target register to be of the same size, so we'll use @max from to@ -- UBFM will set the high bits to 0. SBFM will copy the sign (sign extend). MO_UU_Conv from to -> return $ Any (intFormat to) (\dst -> code `snocOL` UBFM (OpReg (max from to) dst) (OpReg (max from to) reg) (OpImm (ImmInt 0)) (toImm (min from to)))- MO_SS_Conv from to -> return $ Any (intFormat to) (\dst -> code `snocOL` SBFM (OpReg (max from to) dst) (OpReg (max from to) reg) (OpImm (ImmInt 0)) (toImm (min from to)))+ MO_SS_Conv from to -> ss_conv from to reg code MO_FF_Conv from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` FCVT (OpReg to dst) (OpReg from reg)) -- Conversions MO_XX_Conv _from to -> swizzleRegisterRep (intFormat to) <$> getRegister e _ -> pprPanic "getRegister' (monadic CmmMachOp):" (pdoc plat expr)- where toImm W8 = (OpImm (ImmInt 7))- toImm W16 = (OpImm (ImmInt 15))- toImm W32 = (OpImm (ImmInt 31))- toImm W64 = (OpImm (ImmInt 63))- toImm W128 = (OpImm (ImmInt 127))- toImm W256 = (OpImm (ImmInt 255))- toImm W512 = (OpImm (ImmInt 511))+ where+ toImm W8 = (OpImm (ImmInt 7))+ toImm W16 = (OpImm (ImmInt 15))+ toImm W32 = (OpImm (ImmInt 31))+ toImm W64 = (OpImm (ImmInt 63))+ toImm W128 = (OpImm (ImmInt 127))+ toImm W256 = (OpImm (ImmInt 255))+ toImm W512 = (OpImm (ImmInt 511))++ -- In the case of 16- or 8-bit values we need to sign-extend to 32-bits+ -- See Note [Signed arithmetic on AArch64].+ negate code w reg = do+ let w' = opRegWidth w+ return $ Any (intFormat w) $ \dst ->+ code `appOL`+ signExtendReg w w' reg `snocOL`+ NEG (OpReg w' dst) (OpReg w' reg) `appOL`+ truncateReg w' w dst++ ss_conv from to reg code =+ let w' = opRegWidth (max from to)+ in return $ Any (intFormat to) $ \dst ->+ code `snocOL`+ SBFM (OpReg w' dst) (OpReg w' reg) (OpImm (ImmInt 0)) (toImm (min from to)) `appOL`+ -- At this point an 8- or 16-bit value would be sign-extended+ -- to 32-bits. Truncate back down the final width.+ truncateReg w' to dst+ -- Dyadic machops: -- -- The general idea is:@@ -709,40 +782,68 @@ -- Generic case. CmmMachOp op [x, y] -> do -- alright, so we have an operation, and two expressions. And we want to essentially do- -- ensure we get float regs- let genOp w op = do- (reg_x, format_x, code_x) <- getSomeReg x- (reg_y, format_y, code_y) <- getSomeReg y- when ((isFloatFormat format_x && isIntFormat format_y) || (isIntFormat format_x && isFloatFormat format_y)) $ pprPanic "getRegister:genOp" (text "formats don't match:" <+> text (show format_x) <+> text "/=" <+> text (show format_y))- return $ Any format_x (\dst -> code_x `appOL` code_y `appOL` op (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))-- withTempIntReg w op = OpReg w <$> getNewRegNat (intFormat w) >>= op+ -- ensure we get float regs (TODO(Ben): What?)+ let withTempIntReg w op = OpReg w <$> getNewRegNat (intFormat w) >>= op -- withTempFloatReg w op = OpReg w <$> getNewRegNat (floatFormat w) >>= op - intOp w op = do+ -- A "plain" operation.+ bitOp w op = do -- compute x<m> <- x -- compute x<o> <- y -- <OP> x<n>, x<m>, x<o>- (reg_x, _format_x, code_x) <- getSomeReg x- (reg_y, _format_y, code_y) <- getSomeReg y- return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `appOL` op (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))+ (reg_x, format_x, code_x) <- getSomeReg x+ (reg_y, format_y, code_y) <- getSomeReg y+ massertPpr (isIntFormat format_x == isIntFormat format_y) $ text "bitOp: incompatible"+ return $ Any (intFormat w) (\dst ->+ code_x `appOL`+ code_y `appOL`+ op (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))++ -- A (potentially signed) integer operation.+ -- In the case of 8- and 16-bit signed arithmetic we must first+ -- sign-extend both arguments to 32-bits.+ -- See Note [Signed arithmetic on AArch64].+ intOp is_signed w op = do+ -- compute x<m> <- x+ -- compute x<o> <- y+ -- <OP> x<n>, x<m>, x<o>+ (reg_x, format_x, code_x) <- getSomeReg x+ (reg_y, format_y, code_y) <- getSomeReg y+ massertPpr (isIntFormat format_x && isIntFormat format_y) $ text "intOp: non-int"+ -- This is the width of the registers on which the operation+ -- should be performed.+ let w' = opRegWidth w+ signExt r+ | not is_signed = nilOL+ | otherwise = signExtendReg w w' r+ return $ Any (intFormat w) $ \dst ->+ code_x `appOL`+ code_y `appOL`+ -- sign-extend both operands+ signExt reg_x `appOL`+ signExt reg_y `appOL`+ op (OpReg w' dst) (OpReg w' reg_x) (OpReg w' reg_y) `appOL`+ truncateReg w' w dst -- truncate back to the operand's original width+ floatOp w op = do- (reg_fx, _format_x, code_fx) <- getFloatReg x- (reg_fy, _format_y, code_fy) <- getFloatReg y+ (reg_fx, format_x, code_fx) <- getFloatReg x+ (reg_fy, format_y, code_fy) <- getFloatReg y+ massertPpr (isFloatFormat format_x && isFloatFormat format_y) $ text "floatOp: non-float" return $ Any (floatFormat w) (\dst -> code_fx `appOL` code_fy `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy))+ -- need a special one for conditionals, as they return ints floatCond w op = do- (reg_fx, _format_x, code_fx) <- getFloatReg x- (reg_fy, _format_y, code_fy) <- getFloatReg y+ (reg_fx, format_x, code_fx) <- getFloatReg x+ (reg_fy, format_y, code_fy) <- getFloatReg y+ massertPpr (isFloatFormat format_x && isFloatFormat format_y) $ text "floatCond: non-float" return $ Any (intFormat w) (\dst -> code_fx `appOL` code_fy `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy)) case op of -- Integer operations- -- Add/Sub should only be Interger Options.- -- But our Cmm parser doesn't care about types- -- and thus we end up with <float> + <float> => MO_Add <float> <float>- MO_Add w -> genOp w (\d x y -> unitOL $ annExpr expr (ADD d x y))- MO_Sub w -> genOp w (\d x y -> unitOL $ annExpr expr (SUB d x y))+ -- Add/Sub should only be Integer Options.+ MO_Add w -> intOp False w (\d x y -> unitOL $ annExpr expr (ADD d x y))+ -- TODO: Handle sub-word case+ MO_Sub w -> intOp False w (\d x y -> unitOL $ annExpr expr (SUB d x y)) -- Note [CSET] --@@ -781,17 +882,16 @@ -- | AL | Always | Any | 1110 | -- | NV | Never | Any | 1111 | --- '-------------------------------------------------------------------------'- MO_Eq w@W8 -> intOp w (\d x y -> toOL [ SXTB x x, SXTB y y, CMP x y, CSET d EQ ])- MO_Eq w@W16 -> intOp w (\d x y -> toOL [ SXTH x x, SXTH y y, CMP x y, CSET d EQ ])- MO_Eq w -> intOp w (\d x y -> toOL [ CMP x y, CSET d EQ ])- MO_Ne w@W8 -> intOp w (\d x y -> toOL [ SXTB x x, SXTB y y, CMP x y, CSET d NE ])- MO_Ne w@W16 -> intOp w (\d x y -> toOL [ SXTH x x, SXTH y y, CMP x y, CSET d NE ])- MO_Ne w -> intOp w (\d x y -> toOL [ CMP x y, CSET d NE ])- MO_Mul w -> intOp w (\d x y -> unitOL $ MUL d x y) + -- N.B. We needn't sign-extend sub-word size (in)equality comparisons+ -- since we don't care about ordering.+ MO_Eq w -> bitOp w (\d x y -> toOL [ CMP x y, CSET d EQ ])+ MO_Ne w -> bitOp w (\d x y -> toOL [ CMP x y, CSET d NE ])+ -- Signed multiply/divide- MO_S_MulMayOflo w -> intOp w (\d x y -> toOL [ MUL d x y, CSET d VS ])- MO_S_Quot w -> intOp w (\d x y -> unitOL $ SDIV d x y)+ MO_Mul w -> intOp True w (\d x y -> unitOL $ MUL d x y)+ MO_S_MulMayOflo w -> intOp True w (\d x y -> toOL [ MUL d x y, CSET d VS ])+ MO_S_Quot w -> intOp True w (\d x y -> unitOL $ SDIV d x y) -- No native rem instruction. So we'll compute the following -- Rd <- Rx / Ry | 2 <- 7 / 3 -- SDIV Rd Rx Ry@@ -801,41 +901,25 @@ -- '--------------------------' -- Note the swap in Rx and Ry. MO_S_Rem w -> withTempIntReg w $ \t ->- intOp w (\d x y -> toOL [ SDIV t x y, MSUB d t y x ])+ intOp True w (\d x y -> toOL [ SDIV t x y, MSUB d t y x ]) -- Unsigned multiply/divide MO_U_MulMayOflo _w -> unsupportedP plat expr- MO_U_Quot w -> intOp w (\d x y -> unitOL $ UDIV d x y)+ MO_U_Quot w -> intOp False w (\d x y -> unitOL $ UDIV d x y) MO_U_Rem w -> withTempIntReg w $ \t ->- intOp w (\d x y -> toOL [ UDIV t x y, MSUB d t y x ])+ intOp False w (\d x y -> toOL [ UDIV t x y, MSUB d t y x ]) -- Signed comparisons -- see Note [CSET]- MO_S_Ge w@W8 -> intOp w (\d x y -> toOL [ SXTB x x, SXTB y y, CMP x y, CSET d SGE ])- MO_S_Ge w@W16 -> intOp w (\d x y -> toOL [ SXTH x x, SXTH y y, CMP x y, CSET d SGE ])- MO_S_Ge w -> intOp w (\d x y -> toOL [ CMP x y, CSET d SGE ])- MO_S_Le w@W8 -> intOp w (\d x y -> toOL [ SXTB x x, SXTB y y, CMP x y, CSET d SLE ])- MO_S_Le w@W16 -> intOp w (\d x y -> toOL [ SXTH x x, SXTH y y, CMP x y, CSET d SLE ])- MO_S_Le w -> intOp w (\d x y -> toOL [ CMP x y, CSET d SLE ])- MO_S_Gt w@W8 -> intOp w (\d x y -> toOL [ SXTB x x, SXTB y y, CMP x y, CSET d SGT ])- MO_S_Gt w@W16 -> intOp w (\d x y -> toOL [ SXTH x x, SXTH y y, CMP x y, CSET d SGT ])- MO_S_Gt w -> intOp w (\d x y -> toOL [ CMP x y, CSET d SGT ])- MO_S_Lt w@W8 -> intOp w (\d x y -> toOL [ SXTB x x, SXTB y y, CMP x y, CSET d SLT ])- MO_S_Lt w@W16 -> intOp w (\d x y -> toOL [ SXTH x x, SXTH y y, CMP x y, CSET d SLT ])- MO_S_Lt w -> intOp w (\d x y -> toOL [ CMP x y, CSET d SLT ])+ MO_S_Ge w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SGE ])+ MO_S_Le w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SLE ])+ MO_S_Gt w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SGT ])+ MO_S_Lt w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SLT ]) -- Unsigned comparisons- MO_U_Ge w@W8 -> intOp w (\d x y -> toOL [ UXTB x x, UXTB y y, CMP x y, CSET d UGE ])- MO_U_Ge w@W16 -> intOp w (\d x y -> toOL [ UXTH x x, UXTH y y, CMP x y, CSET d UGE ])- MO_U_Ge w -> intOp w (\d x y -> toOL [ CMP x y, CSET d UGE ])- MO_U_Le w@W8 -> intOp w (\d x y -> toOL [ UXTB x x, UXTB y y, CMP x y, CSET d ULE ])- MO_U_Le w@W16 -> intOp w (\d x y -> toOL [ UXTH x x, UXTH y y, CMP x y, CSET d ULE ])- MO_U_Le w -> intOp w (\d x y -> toOL [ CMP x y, CSET d ULE ])- MO_U_Gt w@W8 -> intOp w (\d x y -> toOL [ UXTB x x, UXTB y y, CMP x y, CSET d UGT ])- MO_U_Gt w@W16 -> intOp w (\d x y -> toOL [ UXTH x x, UXTH y y, CMP x y, CSET d UGT ])- MO_U_Gt w -> intOp w (\d x y -> toOL [ CMP x y, CSET d UGT ])- MO_U_Lt w@W8 -> intOp w (\d x y -> toOL [ UXTB x x, UXTB y y, CMP x y, CSET d ULT ])- MO_U_Lt w@W16 -> intOp w (\d x y -> toOL [ UXTH x x, UXTH y y, CMP x y, CSET d ULT ])- MO_U_Lt w -> intOp w (\d x y -> toOL [ CMP x y, CSET d ULT ])+ MO_U_Ge w -> intOp False w (\d x y -> toOL [ CMP x y, CSET d UGE ])+ MO_U_Le w -> intOp False w (\d x y -> toOL [ CMP x y, CSET d ULE ])+ MO_U_Gt w -> intOp False w (\d x y -> toOL [ CMP x y, CSET d UGT ])+ MO_U_Lt w -> intOp False w (\d x y -> toOL [ CMP x y, CSET d ULT ]) -- Floating point arithmetic MO_F_Add w -> floatOp w (\d x y -> unitOL $ ADD d x y)@@ -858,13 +942,12 @@ MO_F_Lt w -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OLT ]) -- x < y <=> y >= x -- Bitwise operations- MO_And w -> intOp w (\d x y -> unitOL $ AND d x y)- MO_Or w -> intOp w (\d x y -> unitOL $ ORR d x y)- MO_Xor w -> intOp w (\d x y -> unitOL $ EOR d x y)- -- MO_Not W64 ->- MO_Shl w -> intOp w (\d x y -> unitOL $ LSL d x y)- MO_U_Shr w -> intOp w (\d x y -> unitOL $ LSR d x y)- MO_S_Shr w -> intOp w (\d x y -> unitOL $ ASR d x y)+ MO_And w -> bitOp w (\d x y -> unitOL $ AND d x y)+ MO_Or w -> bitOp w (\d x y -> unitOL $ ORR d x y)+ MO_Xor w -> bitOp w (\d x y -> unitOL $ EOR d x y)+ MO_Shl w -> intOp False w (\d x y -> unitOL $ LSL d x y)+ MO_U_Shr w -> intOp False w (\d x y -> unitOL $ LSR d x y)+ MO_S_Shr w -> intOp True w (\d x y -> unitOL $ ASR d x y) -- TODO @@ -893,29 +976,58 @@ ,0b1111_1111] +-- | Instructions to sign-extend the value in the given register from width @w@+-- up to width @w'@.+signExtendReg :: Width -> Width -> Reg -> OrdList Instr+signExtendReg w w' r =+ case w of+ W64 -> nilOL+ W32+ | w' == W32 -> nilOL+ | otherwise -> unitOL $ SXTH (OpReg w' r) (OpReg w' r)+ W16 -> unitOL $ SXTH (OpReg w' r) (OpReg w' r)+ W8 -> unitOL $ SXTB (OpReg w' r) (OpReg w' r)+ _ -> panic "intOp"++-- | Instructions to truncate the value in the given register from width @w@+-- down to width @w'@.+truncateReg :: Width -> Width -> Reg -> OrdList Instr+truncateReg w w' r =+ case w of+ W64 -> nilOL+ W32+ | w' == W32 -> nilOL+ _ -> unitOL $ UBFM (OpReg w r)+ (OpReg w r)+ (OpImm (ImmInt 0))+ (OpImm $ ImmInt $ widthInBits w' - 1)+ -- ----------------------------------------------------------------------------- -- The 'Amode' type: Memory addressing modes passed up the tree. data Amode = Amode AddrMode InstrBlock -getAmode :: Platform -> CmmExpr -> NatM Amode+getAmode :: Platform+ -> Width -- ^ width of loaded value+ -> CmmExpr+ -> NatM Amode -- TODO: Specialize stuff we can destructure here. -- OPTIMIZATION WARNING: Addressing modes. -- Addressing options: -- LDUR/STUR: imm9: -256 - 255-getAmode platform (CmmRegOff reg off) | -256 <= off, off <= 255+getAmode platform _ (CmmRegOff reg off) | -256 <= off, off <= 255 = return $ Amode (AddrRegImm reg' off') nilOL where reg' = getRegisterReg platform reg off' = ImmInt off -- LDR/STR: imm12: if reg is 32bit: 0 -- 16380 in multiples of 4-getAmode platform (CmmRegOff reg off)- | typeWidth (cmmRegType platform reg) == W32, 0 <= off, off <= 16380, off `mod` 4 == 0+getAmode platform W32 (CmmRegOff reg off)+ | 0 <= off, off <= 16380, off `mod` 4 == 0 = return $ Amode (AddrRegImm reg' off') nilOL where reg' = getRegisterReg platform reg off' = ImmInt off -- LDR/STR: imm12: if reg is 64bit: 0 -- 32760 in multiples of 8-getAmode platform (CmmRegOff reg off)- | typeWidth (cmmRegType platform reg) == W64, 0 <= off, off <= 32760, off `mod` 8 == 0+getAmode platform W64 (CmmRegOff reg off)+ | 0 <= off, off <= 32760, off `mod` 8 == 0 = return $ Amode (AddrRegImm reg' off') nilOL where reg' = getRegisterReg platform reg off' = ImmInt off@@ -924,18 +1036,18 @@ -- CmmStore (CmmMachOp (MO_Add w) [CmmLoad expr, CmmLit (CmmInt n w')]) (expr2) -- E.g. a CmmStoreOff really. This can be translated to `str $expr2, [$expr, #n ] -- for `n` in range.-getAmode _platform (CmmMachOp (MO_Add _w) [expr, CmmLit (CmmInt off _w')])+getAmode _platform _ (CmmMachOp (MO_Add _w) [expr, CmmLit (CmmInt off _w')]) | -256 <= off, off <= 255 = do (reg, _format, code) <- getSomeReg expr return $ Amode (AddrRegImm reg (ImmInteger off)) code -getAmode _platform (CmmMachOp (MO_Sub _w) [expr, CmmLit (CmmInt off _w')])+getAmode _platform _ (CmmMachOp (MO_Sub _w) [expr, CmmLit (CmmInt off _w')]) | -256 <= -off, -off <= 255 = do (reg, _format, code) <- getSomeReg expr return $ Amode (AddrRegImm reg (ImmInteger (-off))) code -- Generic case-getAmode _platform expr+getAmode _platform _ expr = do (reg, _format, code) <- getSomeReg expr return $ Amode (AddrReg reg) code @@ -961,11 +1073,12 @@ = do (src_reg, _format, code) <- getSomeReg srcE platform <- getPlatform- Amode addr addr_code <- getAmode platform addrE+ let w = formatToWidth rep+ Amode addr addr_code <- getAmode platform w addrE return $ COMMENT (text "CmmStore" <+> parens (text (show addrE)) <+> parens (text (show srcE))) `consOL` (code `appOL` addr_code- `snocOL` STR rep (OpReg (formatToWidth rep) src_reg) (OpAddr addr))+ `snocOL` STR rep (OpReg w src_reg) (OpAddr addr)) assignReg_IntCode _ reg src = do@@ -1152,7 +1265,7 @@ -- -- To actually get the value of <symbol>, we'd need to ldr x0, x0 still, which -- for the first case can be optimized to use ldr x0, [x0, #:lo12:<symbol>]--- instaed of the add instruction.+-- instead of the add instruction. -- -- As the memory model for AArch64 for PIC is considered to be +/- 4GB, we do -- not need to go through the GOT, unless we want to address the full address
compiler/GHC/CmmToAsm/AArch64/Instr.hs view
@@ -28,7 +28,6 @@ import GHC.Utils.Panic -import Control.Monad (replicateM) import Data.Maybe (fromMaybe) import GHC.Stack@@ -461,7 +460,7 @@ allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do let entries = entryBlocks proc - uniqs <- replicateM (length entries) getUniqueM+ uniqs <- getUniquesM let delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up
compiler/GHC/CmmToAsm/AArch64/Ppr.hs view
@@ -544,9 +544,9 @@ #endif LDR _f o1@(OpReg W8 (RegReal (RealRegSingle i))) o2 | i < 32 ->- text "\tldrsb" <+> pprOp platform o1 <> comma <+> pprOp platform o2+ text "\tldrb" <+> pprOp platform o1 <> comma <+> pprOp platform o2 LDR _f o1@(OpReg W16 (RegReal (RealRegSingle i))) o2 | i < 32 ->- text "\tldrsh" <+> pprOp platform o1 <> comma <+> pprOp platform o2+ text "\tldrh" <+> pprOp platform o1 <> comma <+> pprOp platform o2 LDR _f o1 o2 -> text "\tldr" <+> pprOp platform o1 <> comma <+> pprOp platform o2 STP _f o1 o2 o3 -> text "\tstp" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3
compiler/GHC/CmmToAsm/CFG.hs view
@@ -238,7 +238,7 @@ diff = (setUnion cfgNodes blockSet) `setDifference` (setIntersection cfgNodes blockSet) :: LabelSet -- | Filter the CFG with a custom function f.--- Paramaeters are `f from to edgeInfo`+-- Parameters are `f from to edgeInfo` filterEdges :: (BlockId -> BlockId -> EdgeInfo -> Bool) -> CFG -> CFG filterEdges f cfg = mapMapWithKey filterSources cfg
+ compiler/GHC/CmmToAsm/Config.hs view
@@ -0,0 +1,63 @@+-- | Native code generator configuration+module GHC.CmmToAsm.Config+ ( NCGConfig(..)+ , ncgWordWidth+ , ncgSpillPreallocSize+ , platformWordWidth+ )+where++import GHC.Prelude+import GHC.Platform+import GHC.Cmm.Type (Width(..))+import GHC.CmmToAsm.CFG.Weight+import GHC.Unit.Module (Module)+import GHC.Utils.Outputable++-- | Native code generator configuration+data NCGConfig = NCGConfig+ { ncgPlatform :: !Platform -- ^ Target platform+ , ncgAsmContext :: !SDocContext -- ^ Context for ASM code generation+ , ncgThisModule :: !Module -- ^ The name of the module we are currently compiling+ , ncgProcAlignment :: !(Maybe Int) -- ^ Mandatory proc alignment+ , ncgExternalDynamicRefs :: !Bool -- ^ Generate code to link against dynamic libraries+ , ncgPIC :: !Bool -- ^ Enable Position-Independent Code+ , ncgInlineThresholdMemcpy :: !Word -- ^ If inlining `memcpy` produces less than this threshold (in pseudo-instruction unit), do it+ , ncgInlineThresholdMemset :: !Word -- ^ Ditto for `memset`+ , ncgSplitSections :: !Bool -- ^ Split sections+ , ncgRegsIterative :: !Bool+ , ncgRegsGraph :: !Bool+ , ncgAsmLinting :: !Bool -- ^ Perform ASM linting pass+ , ncgDoConstantFolding :: !Bool -- ^ Perform CMM constant folding+ , ncgSseVersion :: Maybe SseVersion -- ^ (x86) SSE instructions+ , ncgBmiVersion :: Maybe BmiVersion -- ^ (x86) BMI instructions+ , ncgDumpRegAllocStages :: !Bool+ , ncgDumpAsmStats :: !Bool+ , ncgDumpAsmConflicts :: !Bool+ , ncgCfgWeights :: !Weights -- ^ CFG edge weights+ , ncgCfgBlockLayout :: !Bool -- ^ Use CFG based block layout algorithm+ , ncgCfgWeightlessLayout :: !Bool -- ^ Layout based on last instruction per block.+ , ncgDwarfEnabled :: !Bool -- ^ Enable Dwarf generation+ , ncgDwarfUnwindings :: !Bool -- ^ Enable unwindings+ , ncgDwarfStripBlockInfo :: !Bool -- ^ Strip out block information from generated Dwarf+ , ncgExposeInternalSymbols :: !Bool -- ^ Expose symbol table entries for internal symbols+ , ncgDwarfSourceNotes :: !Bool -- ^ Enable GHC-specific source note DIEs+ , ncgCmmStaticPred :: !Bool -- ^ Enable static control-flow prediction+ , ncgEnableShortcutting :: !Bool -- ^ Enable shortcutting (don't jump to blocks only containing a jump)+ , ncgComputeUnwinding :: !Bool -- ^ Compute block unwinding tables+ , ncgEnableDeadCodeElimination :: !Bool -- ^ Whether to enable the dead-code elimination+ }++-- | Return Word size+ncgWordWidth :: NCGConfig -> Width+ncgWordWidth config = platformWordWidth (ncgPlatform config)++-- | Size in bytes of the pre-allocated spill space on the C stack+ncgSpillPreallocSize :: NCGConfig -> Int+ncgSpillPreallocSize config = pc_RESERVED_C_STACK_BYTES (platformConstants (ncgPlatform config))++-- | Return Word size+platformWordWidth :: Platform -> Width+platformWordWidth platform = case platformWordSize platform of+ PW4 -> W32+ PW8 -> W64
compiler/GHC/CmmToAsm/PIC.hs view
@@ -209,6 +209,13 @@ -- pointers, code stubs and GOT offsets look like is located in the -- module CLabel. +-- | Helper to check whether the data resides in a DLL or not, see @labelDynamic@+ncgLabelDynamic :: NCGConfig -> CLabel -> Bool+ncgLabelDynamic config = labelDynamic (ncgThisModule config)+ (ncgPlatform config)+ (ncgExternalDynamicRefs config)++ -- We have to decide which labels need to be accessed -- indirectly or via a piece of stub code. data LabelAccessStyle@@ -247,7 +254,7 @@ -- If the target symbol is in another PE we need to access it via the -- appropriate __imp_SYMBOL pointer.- | labelDynamic config lbl+ | ncgLabelDynamic config lbl = AccessViaSymbolPtr -- Target symbol is in the same PE as the caller, so just access it directly.@@ -262,7 +269,7 @@ | not (ncgExternalDynamicRefs config) = AccessDirectly - | labelDynamic config lbl+ | ncgLabelDynamic config lbl = AccessViaSymbolPtr | otherwise@@ -279,7 +286,7 @@ -- howToAccessLabel config arch OSDarwin DataReference lbl -- data access to a dynamic library goes via a symbol pointer- | labelDynamic config lbl+ | ncgLabelDynamic config lbl = AccessViaSymbolPtr -- when generating PIC code, all cross-module data references must@@ -300,7 +307,7 @@ -- stack alignment is only right for regular calls. -- Therefore, we have to go via a symbol pointer: | arch == ArchX86 || arch == ArchX86_64 || arch == ArchAArch64- , labelDynamic config lbl+ , ncgLabelDynamic config lbl = AccessViaSymbolPtr @@ -310,7 +317,7 @@ -- them automatically, neither on Aarch64 (arm64). | arch /= ArchX86_64 , arch /= ArchAArch64- , labelDynamic config lbl+ , ncgLabelDynamic config lbl = AccessViaStub | otherwise@@ -362,7 +369,7 @@ | osElfTarget os = case () of -- A dynamic label needs to be accessed via a symbol pointer.- _ | labelDynamic config lbl+ _ | ncgLabelDynamic config lbl -> AccessViaSymbolPtr -- For PowerPC32 -fPIC, we have to access even static data@@ -390,18 +397,19 @@ howToAccessLabel config arch os CallReference lbl | osElfTarget os- , labelDynamic config lbl && not (ncgPIC config)+ , ncgLabelDynamic config lbl+ , not (ncgPIC config) = AccessDirectly | osElfTarget os , arch /= ArchX86- , labelDynamic config lbl+ , ncgLabelDynamic config lbl , ncgPIC config = AccessViaStub howToAccessLabel config _arch os _kind lbl | osElfTarget os- = if labelDynamic config lbl+ = if ncgLabelDynamic config lbl then AccessViaSymbolPtr else AccessDirectly
compiler/GHC/CmmToAsm/PPC/Instr.hs view
@@ -58,7 +58,6 @@ import GHC.Types.Unique.FM (listToUFM, lookupUFM) import GHC.Types.Unique.Supply -import Control.Monad (replicateM) import Data.Maybe (fromMaybe) @@ -116,7 +115,7 @@ | entry `elem` infos -> infos | otherwise -> entry : infos - uniqs <- replicateM (length entries) getUniqueM+ uniqs <- getUniquesM let delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up
compiler/GHC/CmmToAsm/X86/CodeGen.hs view
@@ -1003,7 +1003,16 @@ -> NatM Register {- Case1: shift length as immediate -}- shift_code width instr x (CmmLit lit) = do+ shift_code width instr x (CmmLit lit)+ -- Handle the case of a shift larger than the width of the shifted value.+ -- This is necessary since x86 applies a mask of 0x1f to the shift+ -- amount, meaning that, e.g., `shr 47, $eax` will actually shift by+ -- `47 & 0x1f == 15`. See #20626.+ | CmmInt n _ <- lit+ , n >= fromIntegral (widthInBits width)+ = getRegister $ CmmLit $ CmmInt 0 width++ | otherwise = do x_code <- getAnyReg x let format = intFormat width
compiler/GHC/CmmToAsm/X86/Instr.hs view
@@ -66,7 +66,6 @@ import GHC.Types.Basic (Alignment) import GHC.Cmm.DebugBlock (UnwindTable) -import Control.Monad import Data.Maybe (fromMaybe) -- Format of an x86/x86_64 memory address, in bytes.@@ -957,7 +956,7 @@ allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do let entries = entryBlocks proc - uniqs <- replicateM (length entries) getUniqueM+ uniqs <- getUniquesM let delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up
compiler/GHC/CmmToC.hs view
@@ -433,18 +433,97 @@ isMulMayOfloOp _ = False pprMachOpApp platform mop args- | Just ty <- machOpNeedsCast mop+ | Just ty <- machOpNeedsCast platform mop (map (cmmExprType platform) args) = ty <> parens (pprMachOpApp' platform mop args) | otherwise = pprMachOpApp' platform mop args --- Comparisons in C have type 'int', but we want type W_ (this is what--- resultRepOfMachOp says). The other C operations inherit their type--- from their operands, so no casting is required.-machOpNeedsCast :: MachOp -> Maybe SDoc-machOpNeedsCast mop+{-+Note [Zero-extending sub-word signed results]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a program like (from #20634):++ test() {+ bits64 ret;+ bits8 a,b;+ a = 0xe1 :: bits8; // == -31 signed+ b = %quot(a, 3::bits8); // == -10 signed+ ret = %zx64(a); // == 0xf6 unsigned+ return (ret);+ }++This program should return 0xf6 == 246. However, we need to be very careful+with when dealing with the result of the %quot. For instance, one might be+tempted produce code like:++ StgWord8 a = 0xe1U;+ StgInt8 b = (StgInt8) a / (StgInt8) 0x3U;+ StgWord ret = (W_) b;++However, this would be wrong; by widening `b` directly from `StgInt8` to+`StgWord` we will get sign-extension semantics: rather than 0xf6 we will get+0xfffffffffffffff6. To avoid this we must first cast `b` back to `StgWord8`,+ensuring that we get zero-extension semantics when we widen up to `StgWord`.++Note [When in doubt, cast arguments as unsigned]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general C's signed-ness behavior can lead to surprising results and+consequently we are very explicit about ensuring that arguments have the+correct signedness. For instance, consider a program like++ test() {+ bits64 ret, a, b;+ a = %neg(43 :: bits64);+ b = %neg(0x443c70fa3e465120 :: bits64);+ ret = %modu(a, b);+ return (ret);+ }++In this case both `a` and `b` will be StgInts in the generated C (since+`MO_Neg` is a signed operation). However, we want to ensure that we perform an+*unsigned* modulus operation, therefore we must be careful to cast both arguments+to StgWord. We do this for any operation where the signedness of the argument+may affect the operation's semantics.+-}++-- | The result type of most operations is determined by the operands. However,+-- there are a few exceptions: particularly operations which might get promoted+-- to a signed result. For these we explicitly cast the result.+machOpNeedsCast :: Platform -> MachOp -> [CmmType] -> Maybe SDoc+machOpNeedsCast platform mop args+ -- Comparisons in C have type 'int', but we want type W_ (this is what+ -- resultRepOfMachOp says). | isComparisonMachOp mop = Just mkW_++ -- See Note [Zero-extended sub-word signed results]+ | signedOp mop+ , res_ty <- machOpResultType platform mop args+ , not $ isFloatType res_ty -- only integer operations, not MO_SF_Conv+ , let w = typeWidth res_ty+ , w < wordWidth platform+ = cast_it w++ -- A shift operation like (a >> b) where a::Word8 and b::Word has type Word+ -- in C yet we want a Word8+ | Just w <- shiftOp mop = cast_it w++ -- The results of these operations may be promoted to signed values+ -- due to C11 section 6.3.1.1.+ | MO_Add w <- mop = cast_it w+ | MO_Sub w <- mop = cast_it w+ | MO_Mul w <- mop = cast_it w+ | MO_U_Quot w <- mop = cast_it w+ | MO_U_Rem w <- mop = cast_it w+ | MO_And w <- mop = cast_it w+ | MO_Or w <- mop = cast_it w+ | MO_Xor w <- mop = cast_it w+ | MO_Not w <- mop = cast_it w+ | otherwise = Nothing+ where+ cast_it w =+ let ty = machRep_U_CType platform w+ in Just $ parens ty pprMachOpApp' :: Platform -> MachOp -> [CmmExpr] -> SDoc pprMachOpApp' platform mop args@@ -458,16 +537,32 @@ _ -> panic "PprC.pprMachOp : machop with wrong number of args" where+ pprArg e+ | needsFCasts mop = cCast platform (machRep_F_CType width) e -- Cast needed for signed integer ops- pprArg e | signedOp mop = cCast platform (machRep_S_CType platform (typeWidth (cmmExprType platform e))) e- | needsFCasts mop = cCast platform (machRep_F_CType (typeWidth (cmmExprType platform e))) e- | otherwise = pprExpr1 platform e- needsFCasts (MO_F_Eq _) = False- needsFCasts (MO_F_Ne _) = False+ | signedOp mop = cCast platform (machRep_S_CType platform width) e+ -- See Note [When in doubt, cast arguments as unsigned]+ | needsUnsignedCast mop+ = cCast platform (machRep_U_CType platform width) e+ | otherwise = pprExpr1 platform e+ where+ width = typeWidth (cmmExprType platform e)+ needsFCasts (MO_F_Neg _) = True needsFCasts (MO_F_Quot _) = True needsFCasts mop = floatComparison mop + -- See Note [When in doubt, cast arguments as unsigned]+ needsUnsignedCast (MO_Mul _) = True+ needsUnsignedCast (MO_U_Shr _) = True+ needsUnsignedCast (MO_U_Quot _) = True+ needsUnsignedCast (MO_U_Rem _) = True+ needsUnsignedCast (MO_U_Ge _) = True+ needsUnsignedCast (MO_U_Le _) = True+ needsUnsignedCast (MO_U_Gt _) = True+ needsUnsignedCast (MO_U_Lt _) = True+ needsUnsignedCast _ = False+ -- -------------------------------------------------------------------------- -- Literals @@ -770,6 +865,12 @@ signedOp (MO_SS_Conv _ _) = True signedOp (MO_SF_Conv _ _) = True signedOp _ = False++shiftOp :: MachOp -> Maybe Width+shiftOp (MO_Shl w) = Just w+shiftOp (MO_U_Shr w) = Just w+shiftOp (MO_S_Shr w) = Just w+shiftOp _ = Nothing floatComparison :: MachOp -> Bool -- comparison between float args floatComparison (MO_F_Eq _) = True
compiler/GHC/CmmToLlvm.hs view
@@ -16,6 +16,7 @@ import GHC.Llvm import GHC.CmmToLlvm.Base import GHC.CmmToLlvm.CodeGen+import GHC.CmmToLlvm.Config import GHC.CmmToLlvm.Data import GHC.CmmToLlvm.Ppr import GHC.CmmToLlvm.Regs@@ -34,7 +35,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Logger-import GHC.SysTools ( figureLlvmVersion ) import qualified GHC.Data.Stream as Stream import Control.Monad ( when, forM_ )@@ -44,10 +44,10 @@ -- ----------------------------------------------------------------------------- -- | Top-level of the LLVM Code generator ---llvmCodeGen :: Logger -> DynFlags -> Handle+llvmCodeGen :: Logger -> LlvmCgConfig -> Handle -> Stream.Stream IO RawCmmGroup a -> IO a-llvmCodeGen logger dflags h cmm_stream+llvmCodeGen logger cfg h cmm_stream = withTiming logger (text "LLVM CodeGen") (const ()) $ do bufh <- newBufHandle h @@ -55,20 +55,20 @@ showPass logger "LLVM CodeGen" -- get llvm version, cache for later use- mb_ver <- figureLlvmVersion logger dflags+ let mb_ver = llvmCgLlvmVersion cfg -- warn if unsupported forM_ mb_ver $ \ver -> do debugTraceMsg logger 2 (text "Using LLVM version:" <+> text (llvmVersionStr ver))- let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags+ let doWarn = llvmCgDoWarn cfg when (not (llvmVersionSupported ver) && doWarn) $ putMsg logger $ "You are using an unsupported version of LLVM!" $$ "Currently only" <+> text (llvmVersionStr supportedLlvmVersionLowerBound) <+> "to" <+> text (llvmVersionStr supportedLlvmVersionUpperBound) <+> "is supported." <+> "System LLVM version: " <> text (llvmVersionStr ver) $$ "We will try though..."- let isS390X = platformArch (targetPlatform dflags) == ArchS390X+ let isS390X = platformArch (llvmCgPlatform cfg) == ArchS390X let major_ver = head . llvmVersionList $ ver when (isS390X && major_ver < 10 && doWarn) $ putMsg logger $ "Warning: For s390x the GHC calling convention is only supported since LLVM version 10." <+>@@ -81,15 +81,15 @@ llvm_ver = fromMaybe supportedLlvmVersionLowerBound mb_ver -- run code generation- a <- runLlvm logger dflags llvm_ver bufh $- llvmCodeGen' dflags cmm_stream+ a <- runLlvm logger cfg llvm_ver bufh $+ llvmCodeGen' cfg cmm_stream bFlush bufh return a -llvmCodeGen' :: DynFlags -> Stream.Stream IO RawCmmGroup a -> LlvmM a-llvmCodeGen' dflags cmm_stream+llvmCodeGen' :: LlvmCgConfig -> Stream.Stream IO RawCmmGroup a -> LlvmM a+llvmCodeGen' cfg cmm_stream = do -- Preamble renderLlvm header ghcInternalFunctions@@ -99,8 +99,7 @@ a <- Stream.consume cmm_stream liftIO llvmGroupLlvmGens -- Declare aliases for forward references- opts <- getLlvmOpts- renderLlvm . pprLlvmData opts =<< generateExternDecls+ renderLlvm . pprLlvmData cfg =<< generateExternDecls -- Postamble cmmUsedLlvmGens@@ -109,8 +108,9 @@ where header :: SDoc header =- let target = platformMisc_llvmTarget $ platformMisc dflags- in text ("target datalayout = \"" ++ getDataLayout (llvmConfig dflags) target ++ "\"")+ let target = llvmCgLlvmTarget cfg+ llvmCfg = llvmCgLlvmConfig cfg+ in text ("target datalayout = \"" ++ getDataLayout llvmCfg target ++ "\"") $+$ text ("target triple = \"" ++ target ++ "\"") getDataLayout :: LlvmConfig -> String -> String@@ -158,8 +158,8 @@ mapM_ regGlobal gs gss' <- mapM aliasify $ gs - opts <- getLlvmOpts- renderLlvm $ pprLlvmData opts (concat gss', concat tss)+ cfg <- getConfig+ renderLlvm $ pprLlvmData cfg (concat gss', concat tss) -- | Complete LLVM code generation phase for a single top-level chunk of Cmm. cmmLlvmGen ::RawCmmDecl -> LlvmM ()@@ -203,8 +203,8 @@ -- just a name on its own. Previously `null` was accepted as the -- name. Nothing -> [ MetaStr name ]- opts <- getLlvmOpts- renderLlvm $ ppLlvmMetas opts metas+ cfg <- getConfig+ renderLlvm $ ppLlvmMetas cfg metas -- ----------------------------------------------------------------------------- -- | Marks variables as used where necessary@@ -222,12 +222,11 @@ -- Which is the LLVM way of protecting them against getting removed. ivars <- getUsedVars let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr- ty = (LMArray (length ivars) i8Ptr)+ ty = LMArray (length ivars) i8Ptr usedArray = LMStaticArray (map cast ivars) ty sectName = Just $ fsLit "llvm.metadata" lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending sectName Nothing Constant lmUsed = LMGlobal lmUsedVar (Just usedArray)- opts <- getLlvmOpts if null ivars then return ()- else renderLlvm $ pprLlvmData opts ([lmUsed], [])+ else getConfig >>= renderLlvm . flip pprLlvmData ([lmUsed], [])
compiler/GHC/CmmToLlvm/Base.hs view
@@ -22,9 +22,9 @@ LlvmM, runLlvm, withClearVars, varLookup, varInsert, markStackReg, checkStackReg,- funLookup, funInsert, getLlvmVer, getDynFlags,+ funLookup, funInsert, getLlvmVer, dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars,- ghcInternalFunctions, getPlatform, getLlvmOpts,+ ghcInternalFunctions, getPlatform, getConfig, getMetaUniqueId, setUniqMeta, getUniqMeta, liftIO,@@ -46,6 +46,7 @@ import GHC.Llvm import GHC.CmmToLlvm.Regs+import GHC.CmmToLlvm.Config import GHC.Cmm.CLabel import GHC.Cmm.Ppr.Expr ()@@ -149,10 +150,10 @@ llvmInfAlign platform = Just (platformWordSizeInBytes platform) -- | Section to use for a function-llvmFunSection :: LlvmOpts -> LMString -> LMSection+llvmFunSection :: LlvmCgConfig -> LMString -> LMSection llvmFunSection opts lbl- | llvmOptsSplitSections opts = Just (concatFS [fsLit ".text.", lbl])- | otherwise = Nothing+ | llvmCgSplitSection opts = Just (concatFS [fsLit ".text.", lbl])+ | otherwise = Nothing -- | A Function's arguments llvmFunArgs :: Platform -> LiveGlobalRegs -> [LlvmVar]@@ -263,9 +264,6 @@ -- * Llvm Version -- -newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int }- deriving (Eq, Ord)- parseLlvmVersion :: String -> Maybe LlvmVersion parseLlvmVersion = fmap LlvmVersion . NE.nonEmpty . go [] . dropWhile (not . isDigit)@@ -303,21 +301,20 @@ -- data LlvmEnv = LlvmEnv- { envVersion :: LlvmVersion -- ^ LLVM version- , envOpts :: LlvmOpts -- ^ LLVM backend options- , envDynFlags :: DynFlags -- ^ Dynamic flags- , envLogger :: !Logger -- ^ Logger- , envOutput :: BufHandle -- ^ Output buffer- , envMask :: !Char -- ^ Mask for creating unique values- , envFreshMeta :: MetaId -- ^ Supply of fresh metadata IDs- , envUniqMeta :: UniqFM Unique MetaId -- ^ Global metadata nodes- , envFunMap :: LlvmEnvMap -- ^ Global functions so far, with type- , envAliases :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References]- , envUsedVars :: [LlvmVar] -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@)+ { envVersion :: LlvmVersion -- ^ LLVM version+ , envConfig :: !LlvmCgConfig -- ^ Configuration for LLVM code gen+ , envLogger :: !Logger -- ^ Logger+ , envOutput :: BufHandle -- ^ Output buffer+ , envMask :: !Char -- ^ Mask for creating unique values+ , envFreshMeta :: MetaId -- ^ Supply of fresh metadata IDs+ , envUniqMeta :: UniqFM Unique MetaId -- ^ Global metadata nodes+ , envFunMap :: LlvmEnvMap -- ^ Global functions so far, with type+ , envAliases :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References]+ , envUsedVars :: [LlvmVar] -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@) -- the following get cleared for every function (see @withClearVars@)- , envVarMap :: LlvmEnvMap -- ^ Local variables so far, with type- , envStackRegs :: [GlobalReg] -- ^ Non-constant registers (alloca'd in the function prelude)+ , envVarMap :: LlvmEnvMap -- ^ Local variables so far, with type+ , envStackRegs :: [GlobalReg] -- ^ Non-constant registers (alloca'd in the function prelude) } type LlvmEnvMap = UniqFM Unique LlvmType@@ -334,20 +331,16 @@ m >>= f = LlvmM $ \env -> do (x, env') <- runLlvmM m env runLlvmM (f x) env' -instance HasDynFlags LlvmM where- getDynFlags = LlvmM $ \env -> return (envDynFlags env, env)- instance HasLogger LlvmM where getLogger = LlvmM $ \env -> return (envLogger env, env) -- | Get target platform getPlatform :: LlvmM Platform-getPlatform = llvmOptsPlatform <$> getLlvmOpts+getPlatform = llvmCgPlatform <$> getConfig --- | Get LLVM options-getLlvmOpts :: LlvmM LlvmOpts-getLlvmOpts = LlvmM $ \env -> return (envOpts env, env)+getConfig :: LlvmM LlvmCgConfig+getConfig = LlvmM $ \env -> return (envConfig env, env) instance MonadUnique LlvmM where getUniqueSupplyM = do@@ -364,23 +357,22 @@ return (x, env) -- | Get initial Llvm environment.-runLlvm :: Logger -> DynFlags -> LlvmVersion -> BufHandle -> LlvmM a -> IO a-runLlvm logger dflags ver out m = do+runLlvm :: Logger -> LlvmCgConfig -> LlvmVersion -> BufHandle -> LlvmM a -> IO a+runLlvm logger cfg ver out m = do (a, _) <- runLlvmM m env return a- where env = LlvmEnv { envFunMap = emptyUFM- , envVarMap = emptyUFM+ where env = LlvmEnv { envFunMap = emptyUFM+ , envVarMap = emptyUFM , envStackRegs = []- , envUsedVars = []- , envAliases = emptyUniqSet- , envVersion = ver- , envOpts = initLlvmOpts dflags- , envDynFlags = dflags- , envLogger = logger- , envOutput = out- , envMask = 'n'+ , envUsedVars = []+ , envAliases = emptyUniqSet+ , envVersion = ver+ , envConfig = cfg+ , envLogger = logger+ , envOutput = out+ , envMask = 'n' , envFreshMeta = MetaId 0- , envUniqMeta = emptyUFM+ , envUniqMeta = emptyUFM } -- | Get environment (internal)@@ -435,9 +427,8 @@ renderLlvm sdoc = do -- Write to output- dflags <- getDynFlags+ ctx <- llvmCgContext <$> getConfig out <- getEnv envOutput- let ctx = initSDocContext dflags (Outp.PprCode Outp.CStyle) liftIO $ Outp.bufLeftRenderSDoc ctx out sdoc -- Dump, if requested@@ -499,12 +490,10 @@ -- | Pretty print a 'CLabel'. strCLabel_llvm :: CLabel -> LlvmM LMString strCLabel_llvm lbl = do- dflags <- getDynFlags+ ctx <- llvmCgContext <$> getConfig platform <- getPlatform let sdoc = pprCLabel platform CStyle lbl- str = Outp.renderWithContext- (initSDocContext dflags (Outp.PprCode Outp.CStyle))- sdoc+ str = Outp.renderWithContext ctx sdoc return (fsLit str) -- ----------------------------------------------------------------------------
compiler/GHC/CmmToLlvm/CodeGen.hs view
@@ -8,14 +8,12 @@ import GHC.Prelude -import GHC.Driver.Session-import GHC.Driver.Ppr- import GHC.Platform import GHC.Platform.Regs ( activeStgRegs ) import GHC.Llvm import GHC.CmmToLlvm.Base+import GHC.CmmToLlvm.Config import GHC.CmmToLlvm.Regs import GHC.Cmm.BlockId@@ -692,14 +690,13 @@ ForeignTarget expr _ -> do (v1, stmts, top) <- exprToVar expr- dflags <- getDynFlags let fty = funTy $ fsLit "dynamic" cast = case getVarType v1 of ty | isPointer ty -> LM_Bitcast ty | isInt ty -> LM_Inttoptr - ty -> panic $ "genCall: Expr is of bad type for function"- ++ " call! (" ++ showSDoc dflags (ppr ty) ++ ")"+ ty -> pprPanic "genCall: Expr is of bad type for function" $+ text " call! " <> lparen <> ppr ty <> rparen (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty) return (v2, stmts `snocOL` s1, top)@@ -728,13 +725,12 @@ arg_vars ((e, AddrHint):rest) (vars, stmts, tops) = do (v1, stmts', top') <- exprToVar e- dflags <- getDynFlags let op = case getVarType v1 of ty | isPointer ty -> LM_Bitcast ty | isInt ty -> LM_Inttoptr - a -> panic $ "genCall: Can't cast llvmType to i8*! ("- ++ showSDoc dflags (ppr a) ++ ")"+ a -> pprPanic "genCall: Can't cast llvmType to i8*! " $+ lparen <> ppr a <> rparen (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr arg_vars rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1,@@ -768,8 +764,7 @@ = return (v, Nop) | otherwise- = do dflags <- getDynFlags- platform <- getPlatform+ = do platform <- getPlatform let op = case (getVarType v, t) of (LMInt n, LMInt m) -> if n < m then extend else LM_Trunc@@ -783,8 +778,11 @@ (vt, _) | isPointer vt && isPointer t -> LM_Bitcast (vt, _) | isVector vt && isVector t -> LM_Bitcast - (vt, _) -> panic $ "castVars: Can't cast this type ("- ++ showSDoc dflags (ppr vt) ++ ") to (" ++ showSDoc dflags (ppr t) ++ ")"+ (vt, _) -> pprPanic "castVars: Can't cast this type " $+ lparen <> ppr vt <> rparen+ <> text " to " <>+ lparen <> ppr t <> rparen+ doExpr t $ Cast op v t where extend = case signage of Signed -> LM_Sext@@ -800,11 +798,10 @@ -- | Decide what C function to use to implement a CallishMachOp cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString cmmPrimOpFunctions mop = do-- dflags <- getDynFlags+ cfg <- getConfig platform <- getPlatform- let intrinTy1 = "p0i8.p0i8." ++ showSDoc dflags (ppr $ llvmWord platform)- intrinTy2 = "p0i8." ++ showSDoc dflags (ppr $ llvmWord platform)+ let !isBmi2Enabled = llvmCgBmiVersion cfg >= Just BMI2+ !is32bit = platformWordSize platform == PW4 unsupported = panic ("cmmPrimOpFunctions: " ++ show mop ++ " not supported here") dontReach64 = panic ("cmmPrimOpFunctions: " ++ show mop@@ -859,42 +856,150 @@ MO_F64_Acosh -> fsLit "acosh" MO_F64_Atanh -> fsLit "atanh" - MO_Memcpy _ -> fsLit $ "llvm.memcpy." ++ intrinTy1- MO_Memmove _ -> fsLit $ "llvm.memmove." ++ intrinTy1- MO_Memset _ -> fsLit $ "llvm.memset." ++ intrinTy2- MO_Memcmp _ -> fsLit $ "memcmp"+ -- In the following ops, it looks like we could factorize the concatenation+ -- of the bit size, and indeed it was like this before, e.g.+ --+ -- MO_PopCnt w -> fsLit $ "llvm.ctpop.i" ++ wbits w+ -- or+ -- MO_Memcpy _ -> fsLit $ "llvm.memcpy." ++ intrinTy1+ --+ -- however it meant that FastStrings were not built from constant string+ -- literals, hence they weren't matching the "fslit" rewrite rule in+ -- GHC.Data.FastString that computes the string size at compilation time. - MO_SuspendThread -> fsLit $ "suspendThread"- MO_ResumeThread -> fsLit $ "resumeThread"+ MO_Memcpy _+ | is32bit -> fsLit "llvm.memcpy.p0i8.p0i8.i32"+ | otherwise -> fsLit "llvm.memcpy.p0i8.p0i8.i64"+ MO_Memmove _+ | is32bit -> fsLit "llvm.memmove.p0i8.p0i8.i32"+ | otherwise -> fsLit "llvm.memmove.p0i8.p0i8.i64"+ MO_Memset _+ | is32bit -> fsLit "llvm.memset.p0i8.i32"+ | otherwise -> fsLit "llvm.memset.p0i8.i64"+ MO_Memcmp _ -> fsLit "memcmp" - (MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ showSDoc dflags (ppr $ widthToLlvmInt w)- (MO_BSwap w) -> fsLit $ "llvm.bswap." ++ showSDoc dflags (ppr $ widthToLlvmInt w)- (MO_BRev w) -> fsLit $ "llvm.bitreverse." ++ showSDoc dflags (ppr $ widthToLlvmInt w)- (MO_Clz w) -> fsLit $ "llvm.ctlz." ++ showSDoc dflags (ppr $ widthToLlvmInt w)- (MO_Ctz w) -> fsLit $ "llvm.cttz." ++ showSDoc dflags (ppr $ widthToLlvmInt w)+ MO_SuspendThread -> fsLit "suspendThread"+ MO_ResumeThread -> fsLit "resumeThread" - (MO_Pdep w) -> let w' = showSDoc dflags (ppr $ widthInBits w)- in if isBmi2Enabled dflags- then fsLit $ "llvm.x86.bmi.pdep." ++ w'- else fsLit $ "hs_pdep" ++ w'- (MO_Pext w) -> let w' = showSDoc dflags (ppr $ widthInBits w)- in if isBmi2Enabled dflags- then fsLit $ "llvm.x86.bmi.pext." ++ w'- else fsLit $ "hs_pext" ++ w'+ MO_PopCnt w -> case w of+ W8 -> fsLit "llvm.ctpop.i8"+ W16 -> fsLit "llvm.ctpop.i16"+ W32 -> fsLit "llvm.ctpop.i32"+ W64 -> fsLit "llvm.ctpop.i64"+ W128 -> fsLit "llvm.ctpop.i128"+ W256 -> fsLit "llvm.ctpop.i256"+ W512 -> fsLit "llvm.ctpop.i512"+ MO_BSwap w -> case w of+ W8 -> fsLit "llvm.bswap.i8"+ W16 -> fsLit "llvm.bswap.i16"+ W32 -> fsLit "llvm.bswap.i32"+ W64 -> fsLit "llvm.bswap.i64"+ W128 -> fsLit "llvm.bswap.i128"+ W256 -> fsLit "llvm.bswap.i256"+ W512 -> fsLit "llvm.bswap.i512"+ MO_BRev w -> case w of+ W8 -> fsLit "llvm.bitreverse.i8"+ W16 -> fsLit "llvm.bitreverse.i16"+ W32 -> fsLit "llvm.bitreverse.i32"+ W64 -> fsLit "llvm.bitreverse.i64"+ W128 -> fsLit "llvm.bitreverse.i128"+ W256 -> fsLit "llvm.bitreverse.i256"+ W512 -> fsLit "llvm.bitreverse.i512"+ MO_Clz w -> case w of+ W8 -> fsLit "llvm.ctlz.i8"+ W16 -> fsLit "llvm.ctlz.i16"+ W32 -> fsLit "llvm.ctlz.i32"+ W64 -> fsLit "llvm.ctlz.i64"+ W128 -> fsLit "llvm.ctlz.i128"+ W256 -> fsLit "llvm.ctlz.i256"+ W512 -> fsLit "llvm.ctlz.i512"+ MO_Ctz w -> case w of+ W8 -> fsLit "llvm.cttz.i8"+ W16 -> fsLit "llvm.cttz.i16"+ W32 -> fsLit "llvm.cttz.i32"+ W64 -> fsLit "llvm.cttz.i64"+ W128 -> fsLit "llvm.cttz.i128"+ W256 -> fsLit "llvm.cttz.i256"+ W512 -> fsLit "llvm.cttz.i512"+ MO_Pdep w+ | isBmi2Enabled -> case w of+ W8 -> fsLit "llvm.x86.bmi.pdep.8"+ W16 -> fsLit "llvm.x86.bmi.pdep.16"+ W32 -> fsLit "llvm.x86.bmi.pdep.32"+ W64 -> fsLit "llvm.x86.bmi.pdep.64"+ W128 -> fsLit "llvm.x86.bmi.pdep.128"+ W256 -> fsLit "llvm.x86.bmi.pdep.256"+ W512 -> fsLit "llvm.x86.bmi.pdep.512"+ | otherwise -> case w of+ W8 -> fsLit "hs_pdep8"+ W16 -> fsLit "hs_pdep16"+ W32 -> fsLit "hs_pdep32"+ W64 -> fsLit "hs_pdep64"+ W128 -> fsLit "hs_pdep128"+ W256 -> fsLit "hs_pdep256"+ W512 -> fsLit "hs_pdep512"+ MO_Pext w+ | isBmi2Enabled -> case w of+ W8 -> fsLit "llvm.x86.bmi.pext.8"+ W16 -> fsLit "llvm.x86.bmi.pext.16"+ W32 -> fsLit "llvm.x86.bmi.pext.32"+ W64 -> fsLit "llvm.x86.bmi.pext.64"+ W128 -> fsLit "llvm.x86.bmi.pext.128"+ W256 -> fsLit "llvm.x86.bmi.pext.256"+ W512 -> fsLit "llvm.x86.bmi.pext.512"+ | otherwise -> case w of+ W8 -> fsLit "hs_pext8"+ W16 -> fsLit "hs_pext16"+ W32 -> fsLit "hs_pext32"+ W64 -> fsLit "hs_pext64"+ W128 -> fsLit "hs_pext128"+ W256 -> fsLit "hs_pext256"+ W512 -> fsLit "hs_pext512" - (MO_Prefetch_Data _ )-> fsLit "llvm.prefetch"+ MO_AddIntC w -> case w of+ W8 -> fsLit "llvm.sadd.with.overflow.i8"+ W16 -> fsLit "llvm.sadd.with.overflow.i16"+ W32 -> fsLit "llvm.sadd.with.overflow.i32"+ W64 -> fsLit "llvm.sadd.with.overflow.i64"+ W128 -> fsLit "llvm.sadd.with.overflow.i128"+ W256 -> fsLit "llvm.sadd.with.overflow.i256"+ W512 -> fsLit "llvm.sadd.with.overflow.i512"+ MO_SubIntC w -> case w of+ W8 -> fsLit "llvm.ssub.with.overflow.i8"+ W16 -> fsLit "llvm.ssub.with.overflow.i16"+ W32 -> fsLit "llvm.ssub.with.overflow.i32"+ W64 -> fsLit "llvm.ssub.with.overflow.i64"+ W128 -> fsLit "llvm.ssub.with.overflow.i128"+ W256 -> fsLit "llvm.ssub.with.overflow.i256"+ W512 -> fsLit "llvm.ssub.with.overflow.i512"+ MO_Add2 w -> case w of+ W8 -> fsLit "llvm.uadd.with.overflow.i8"+ W16 -> fsLit "llvm.uadd.with.overflow.i16"+ W32 -> fsLit "llvm.uadd.with.overflow.i32"+ W64 -> fsLit "llvm.uadd.with.overflow.i64"+ W128 -> fsLit "llvm.uadd.with.overflow.i128"+ W256 -> fsLit "llvm.uadd.with.overflow.i256"+ W512 -> fsLit "llvm.uadd.with.overflow.i512"+ MO_AddWordC w -> case w of+ W8 -> fsLit "llvm.uadd.with.overflow.i8"+ W16 -> fsLit "llvm.uadd.with.overflow.i16"+ W32 -> fsLit "llvm.uadd.with.overflow.i32"+ W64 -> fsLit "llvm.uadd.with.overflow.i64"+ W128 -> fsLit "llvm.uadd.with.overflow.i128"+ W256 -> fsLit "llvm.uadd.with.overflow.i256"+ W512 -> fsLit "llvm.uadd.with.overflow.i512"+ MO_SubWordC w -> case w of+ W8 -> fsLit "llvm.usub.with.overflow.i8"+ W16 -> fsLit "llvm.usub.with.overflow.i16"+ W32 -> fsLit "llvm.usub.with.overflow.i32"+ W64 -> fsLit "llvm.usub.with.overflow.i64"+ W128 -> fsLit "llvm.usub.with.overflow.i128"+ W256 -> fsLit "llvm.usub.with.overflow.i256"+ W512 -> fsLit "llvm.usub.with.overflow.i512" - MO_AddIntC w -> fsLit $ "llvm.sadd.with.overflow."- ++ showSDoc dflags (ppr $ widthToLlvmInt w)- MO_SubIntC w -> fsLit $ "llvm.ssub.with.overflow."- ++ showSDoc dflags (ppr $ widthToLlvmInt w)- MO_Add2 w -> fsLit $ "llvm.uadd.with.overflow."- ++ showSDoc dflags (ppr $ widthToLlvmInt w)- MO_AddWordC w -> fsLit $ "llvm.uadd.with.overflow."- ++ showSDoc dflags (ppr $ widthToLlvmInt w)- MO_SubWordC w -> fsLit $ "llvm.usub.with.overflow."- ++ showSDoc dflags (ppr $ widthToLlvmInt w) + MO_Prefetch_Data _ -> fsLit "llvm.prefetch"+ MO_S_Mul2 {} -> unsupported MO_S_QuotRem {} -> unsupported MO_U_QuotRem {} -> unsupported@@ -960,14 +1065,13 @@ genJump expr live = do fty <- llvmFunTy live (vf, stmts, top) <- exprToVar expr- dflags <- getDynFlags let cast = case getVarType vf of ty | isPointer ty -> LM_Bitcast ty | isInt ty -> LM_Inttoptr - ty -> panic $ "genJump: Expr is of bad type for function call! ("- ++ showSDoc dflags (ppr ty) ++ ")"+ ty -> pprPanic "genJump: Expr is of bad type for function call! "+ $ lparen <> ppr ty <> rparen (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty) (stgRegs, stgStmts) <- funEpilogue live@@ -1078,9 +1182,8 @@ (vval, stmts2, top2) <- exprToVar val let stmts = stmts1 `appOL` stmts2- dflags <- getDynFlags platform <- getPlatform- opts <- getLlvmOpts+ cfg <- getConfig case getVarType vaddr of -- sometimes we need to cast an int to a pointer before storing LMPointer ty@(LMPointer _) | getVarType vval == llvmWord platform -> do@@ -1101,9 +1204,9 @@ other -> pprPanic "genStore: ptr not right type!" (PprCmm.pprExpr platform addr <+> text (- "Size of Ptr: " ++ show (llvmPtrBits platform) +++ "Size of Ptr: " ++ show (llvmPtrBits platform) ++ ", Size of var: " ++ show (llvmWidthInBits platform other) ++- ", Var: " ++ showSDoc dflags (ppVar opts vaddr)))+ ", Var: " ++ renderWithContext (llvmCgContext cfg) (ppVar cfg vaddr))) -- | Unconditional branch@@ -1128,22 +1231,22 @@ let s1 = BranchIf vc' labelT labelF return (stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2) else do- dflags <- getDynFlags- opts <- getLlvmOpts- panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppVar opts vc) ++ ")"+ cfg <- getConfig+ pprPanic "genCondBranch: Cond expr not bool! " $+ lparen <> ppVar cfg vc <> rparen -- | Generate call to llvm.expect.x intrinsic. Assigning result to a new var. genExpectLit :: Integer -> LlvmType -> LlvmVar -> LlvmM (LlvmVar, StmtData) genExpectLit expLit expTy var = do- dflags <- getDynFlags+ cfg <- getConfig let lit = LMLitVar $ LMIntLit expLit expTy llvmExpectName- | isInt expTy = fsLit $ "llvm.expect." ++ showSDoc dflags (ppr expTy)- | otherwise = panic $ "genExpectedLit: Type not an int!"+ | isInt expTy = fsLit $ "llvm.expect." ++ renderWithContext (llvmCgContext cfg) (ppr expTy)+ | otherwise = panic "genExpectedLit: Type not an int!" (llvmExpect, stmts, top) <- getInstrinct llvmExpectName expTy [expTy, expTy]@@ -1593,6 +1696,7 @@ where binLlvmOp ty binOp allow_y_cast = do+ cfg <- getConfig platform <- getPlatform runExprData $ do vx <- exprToVarW x@@ -1610,10 +1714,8 @@ | otherwise -> do -- Error. Continue anyway so we can debug the generated ll file.- dflags <- getDynFlags- let style = PprCode CStyle- toString doc = renderWithContext (initSDocContext dflags style) doc- cmmToStr = (lines . toString . PprCmm.pprExpr platform)+ let render = renderWithContext (llvmCgContext cfg)+ cmmToStr = (lines . render . PprCmm.pprExpr platform) statement $ Comment $ map fsLit $ cmmToStr x statement $ Comment $ map fsLit $ cmmToStr y doExprW (ty vx) $ binOp vx vy@@ -1630,8 +1732,7 @@ -- comparisons while LLVM return i1. Need to extend to llvmWord type -- if expected. See Note [Literals and branch conditions]. genBinComp opt cmp = do- ed@(v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp) False- dflags <- getDynFlags+ ed@(v1, stmts, top) <- binLlvmOp (const i1) (Compare cmp) False platform <- getPlatform if getVarType v1 == i1 then case i1Expected opt of@@ -1641,8 +1742,8 @@ (v2, s1) <- doExpr w_ $ Cast LM_Zext v1 w_ return (v2, stmts `snocOL` s1, top) else- panic $ "genBinComp: Compare returned type other then i1! "- ++ (showSDoc dflags $ ppr $ getVarType v1)+ pprPanic "genBinComp: Compare returned type other then i1! "+ (ppr $ getVarType v1) genBinMach op = binLlvmOp getVarType (LlvmOp op) False @@ -1657,13 +1758,12 @@ isSMulOK :: Width -> CmmExpr -> CmmExpr -> LlvmM ExprData isSMulOK _ x y = do platform <- getPlatform- dflags <- getDynFlags runExprData $ do vx <- exprToVarW x vy <- exprToVarW y let word = getVarType vx- let word2 = LMInt $ 2 * (llvmWidthInBits platform $ getVarType vx)+ let word2 = LMInt $ 2 * llvmWidthInBits platform (getVarType vx) let shift = llvmWidthInBits platform word let shift1 = toIWord platform (shift - 1) let shift2 = toIWord platform shift@@ -1680,7 +1780,8 @@ doExprW word $ LlvmOp LM_MO_Sub rlow2 rhigh2 else- panic $ "isSMulOK: Not bit type! (" ++ showSDoc dflags (ppr word) ++ ")"+ pprPanic "isSMulOK: Not bit type! " $+ lparen <> ppr word <> rparen panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encountered" ++ "with two arguments! (" ++ show op ++ ")"@@ -1760,8 +1861,7 @@ genLoad_slow :: Atomic -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData genLoad_slow atomic e ty meta = do platform <- getPlatform- dflags <- getDynFlags- opts <- getLlvmOpts+ cfg <- getConfig runExprData $ do iptr <- exprToVarW e case getVarType iptr of@@ -1775,9 +1875,9 @@ other -> pprPanic "exprToVar: CmmLoad expression is not right type!" (PprCmm.pprExpr platform e <+> text (- "Size of Ptr: " ++ show (llvmPtrBits platform) +++ "Size of Ptr: " ++ show (llvmPtrBits platform) ++ ", Size of var: " ++ show (llvmWidthInBits platform other) ++- ", Var: " ++ showSDoc dflags (ppVar opts iptr)))+ ", Var: " ++ renderWithContext (llvmCgContext cfg) (ppVar cfg iptr))) where loadInstr ptr | atomic = ALoad SyncSeqCst False ptr | otherwise = Load ptr@@ -1789,21 +1889,21 @@ getCmmReg :: CmmReg -> LlvmM LlvmVar getCmmReg (CmmLocal (LocalReg un _)) = do exists <- varLookup un- dflags <- getDynFlags case exists of Just ety -> return (LMLocalVar un $ pLift ety)- Nothing -> panic $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr un) ++ " was not allocated!"+ Nothing -> pprPanic "getCmmReg: Cmm register " $+ ppr un <> text " was not allocated!" -- This should never happen, as every local variable should -- have been assigned a value at some point, triggering -- "funPrologue" to allocate it on the stack. getCmmReg (CmmGlobal g)- = do onStack <- checkStackReg g- dflags <- getDynFlags+ = do onStack <- checkStackReg g platform <- getPlatform if onStack then return (lmGlobalRegVar platform g)- else panic $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr g) ++ " not stack-allocated!"+ else pprPanic "getCmmReg: Cmm register " $+ ppr g <> text " not stack-allocated!" -- | Return the value of a given register, as well as its type. Might -- need to be load from stack.
+ compiler/GHC/CmmToLlvm/Config.hs view
@@ -0,0 +1,31 @@+-- | Llvm code generator configuration+module GHC.CmmToLlvm.Config+ ( LlvmCgConfig(..)+ , LlvmVersion(..)+ )+where++import GHC.Prelude+import GHC.Platform++import GHC.Utils.Outputable+import GHC.Driver.Session++import qualified Data.List.NonEmpty as NE++newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int }+ deriving (Eq, Ord)++data LlvmCgConfig = LlvmCgConfig+ { llvmCgPlatform :: !Platform -- ^ Target platform+ , llvmCgContext :: !SDocContext -- ^ Context for LLVM code generation+ , llvmCgFillUndefWithGarbage :: !Bool -- ^ Fill undefined literals with garbage values+ , llvmCgSplitSection :: !Bool -- ^ Split sections+ , llvmCgBmiVersion :: Maybe BmiVersion -- ^ (x86) BMI instructions+ , llvmCgLlvmVersion :: Maybe LlvmVersion -- ^ version of Llvm we're using+ , llvmCgDoWarn :: !Bool -- ^ True ==> warn unsupported Llvm version+ , llvmCgLlvmTarget :: !String -- ^ target triple passed to LLVM+ , llvmCgLlvmConfig :: !LlvmConfig -- ^ mirror DynFlags LlvmConfig.+ -- see Note [LLVM Configuration] in "GHC.SysTools". This can be strict since+ -- GHC.Driver.Config.CmmToLlvm.initLlvmCgConfig verifies the files are present.+ }
compiler/GHC/CmmToLlvm/Data.hs view
@@ -11,6 +11,7 @@ import GHC.Llvm import GHC.CmmToLlvm.Base+import GHC.CmmToLlvm.Config import GHC.Cmm.BlockId import GHC.Cmm.CLabel@@ -110,9 +111,9 @@ -- | Format a Cmm Section into a LLVM section name llvmSection :: Section -> LlvmM LMSection llvmSection (Section t suffix) = do- opts <- getLlvmOpts- let splitSect = llvmOptsSplitSections opts- platform = llvmOptsPlatform opts+ opts <- getConfig+ let splitSect = llvmCgSplitSection opts+ platform = llvmCgPlatform opts if not splitSect then return Nothing else do
compiler/GHC/CmmToLlvm/Ppr.hs view
@@ -9,11 +9,10 @@ import GHC.Prelude -import GHC.Driver.Ppr- import GHC.Llvm import GHC.CmmToLlvm.Base import GHC.CmmToLlvm.Data+import GHC.CmmToLlvm.Config import GHC.Cmm.CLabel import GHC.Cmm@@ -27,21 +26,21 @@ -- -- | Pretty print LLVM data code-pprLlvmData :: LlvmOpts -> LlvmData -> SDoc-pprLlvmData opts (globals, types) =+pprLlvmData :: LlvmCgConfig -> LlvmData -> SDoc+pprLlvmData cfg (globals, types) = let ppLlvmTys (LMAlias a) = ppLlvmAlias a ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f ppLlvmTys _other = empty types' = vcat $ map ppLlvmTys types- globals' = ppLlvmGlobals opts globals+ globals' = ppLlvmGlobals cfg globals in types' $+$ globals' -- | Pretty print LLVM code pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar]) pprLlvmCmmDecl (CmmData _ lmdata) = do- opts <- getLlvmOpts+ opts <- getConfig return (vcat $ map (pprLlvmData opts) lmdata, []) pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))@@ -54,13 +53,12 @@ lmblocks = map (\(BasicBlock id stmts) -> LlvmBlock (getUnique id) stmts) blks - funDec <- llvmFunSig live lbl link- dflags <- getDynFlags- opts <- getLlvmOpts+ funDec <- llvmFunSig live lbl link+ cfg <- getConfig platform <- getPlatform- let buildArg = fsLit . showSDoc dflags . ppPlainName opts+ let buildArg = fsLit . renderWithContext (llvmCgContext cfg). ppPlainName cfg funArgs = map buildArg (llvmFunArgs platform live)- funSect = llvmFunSection opts (decName funDec)+ funSect = llvmFunSection cfg (decName funDec) -- generate the info table prefix <- case mb_info of@@ -94,7 +92,7 @@ (Just $ LMBitc (LMStaticPointer defVar) i8Ptr) - return (ppLlvmGlobal opts alias $+$ ppLlvmFunction opts fun', [])+ return (ppLlvmGlobal cfg alias $+$ ppLlvmFunction cfg fun', []) -- | The section we are putting info tables and their entry code into, should
compiler/GHC/Core/Opt/Pipeline.hs view
@@ -72,6 +72,7 @@ import Control.Monad import qualified GHC.LanguageExtensions as LangExt+import GHC.Unit.Module {- ************************************************************************ * *@@ -92,7 +93,7 @@ ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_mask mod orph_mods print_unqual loc $ do { hsc_env' <- getHscEnv- ; all_passes <- withPlugins hsc_env'+ ; all_passes <- withPlugins (hsc_plugins hsc_env') installCoreToDos builtin_passes ; runCorePasses all_passes guts }@@ -106,7 +107,8 @@ where logger = hsc_logger hsc_env dflags = hsc_dflags hsc_env- home_pkg_rules = hptRules hsc_env (dep_direct_mods deps)+ home_pkg_rules = hptRules hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod+ , gwib_isBoot = NotBoot }) hpt_rule_base = mkRuleBase home_pkg_rules print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.@@ -127,10 +129,10 @@ getCoreToDo logger dflags = flatten_todos core_todo where- opt_level = optLevel dflags phases = simplPhases dflags max_iter = maxSimplIterations dflags rule_check = ruleCheck dflags+ const_fold = gopt Opt_CoreConstantFolding dflags call_arity = gopt Opt_CallArity dflags exitification = gopt Opt_Exitification dflags strictness = gopt Opt_Strictness dflags@@ -150,6 +152,9 @@ static_ptrs = xopt LangExt.StaticPointers dflags profiling = ways dflags `hasWay` WayProf + do_presimplify = do_specialise -- TODO: any other optimizations benefit from pre-simplification?+ do_simpl3 = const_fold || rules_on -- TODO: any other optimizations benefit from three-phase simplification?+ maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase) maybe_strictness_before (Phase phase)@@ -220,14 +225,7 @@ runWhen (profiling && not (null $ callerCcFilters dflags)) CoreAddCallerCcs core_todo =- if opt_level == 0 then- [ static_ptrs_float_outwards- , simplify "Non-opt simplification"- , add_caller_ccs- ]-- else {- opt_level >= 1 -} [-+ [ -- We want to do the static argument transform before full laziness as it -- may expose extra opportunities to float things outwards. However, to fix -- up the output of the transformation we need at do at least one simplify@@ -235,7 +233,7 @@ runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]), -- initial simplify: mk specialiser happy: minimum effort please- simpl_gently,+ runWhen do_presimplify simpl_gently, -- Specialisation is best done before full laziness -- so that overloaded functions have all their dictionary lambdas manifest@@ -271,9 +269,10 @@ static_ptrs_float_outwards, -- Run the simplier phases 2,1,0 to allow rewrite rules to fire- CoreDoPasses [ simpl_phase (Phase phase) "main" max_iter- | phase <- [phases, phases-1 .. 1] ],- simpl_phase (Phase 0) "main" (max max_iter 3),+ runWhen do_simpl3+ (CoreDoPasses $ [ simpl_phase (Phase phase) "main" max_iter+ | phase <- [phases, phases-1 .. 1] ] +++ [ simpl_phase (Phase 0) "main" (max max_iter 3) ]), -- Phase 0: allow all Ids to be inlined now -- This gets foldr inlined before strictness analysis
compiler/GHC/Core/Opt/SetLevels.hs view
@@ -55,9 +55,9 @@ This can only work if @wild@ is an unrestricted binder. Indeed, even with the extended typing rule (in the linter) for case expressions, if- case x of wild # 1 { p -> e}+ case x of wild % 1 { p -> e} is well-typed, then- case x of wild # 1 { p -> e[wild\x] }+ case x of wild % 1 { p -> e[wild\x] } is only well-typed if @e[wild\x] = e@ (that is, if @wild@ is not used in @e@ at all). In which case, it is, of course, pointless to do the substitution anyway. So for a linear binder (and really anything which isn't unrestricted),@@ -1594,7 +1594,7 @@ , le_env = emptyVarEnv } where in_scope_toplvl = emptyInScopeSet `extendInScopeSetList` bindersOfBinds binds- -- The Simplifier (see Note [Glomming] in GHC.Core.Opt.Occuranal) and+ -- The Simplifier (see Note [Glomming] in GHC.Core.Opt.OccurAnal) and -- the specialiser (see Note [Top level scope] in GHC.Core.Opt.Specialise) -- may both produce top-level bindings where an early binding refers -- to a later one. So here we put all the top-level binders in scope before
compiler/GHC/Core/Opt/Simplify.hs view
@@ -45,7 +45,7 @@ import GHC.Core.Rules ( lookupRule, getRules, initRuleOpts ) import GHC.Core.Multiplicity -import GHC.Types.Literal ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326+import GHC.Types.Literal ( litIsLifted ) --, mkLitInt ) -- temporarily commented out. See #8326 import GHC.Types.SourceText import GHC.Types.Id import GHC.Types.Id.Make ( seqId )
compiler/GHC/Core/Opt/SpecConstr.hs view
@@ -2003,7 +2003,7 @@ in ... f (K @(a |> co)) ... where 'co' is a coercion variable not in scope at f's definition site.-If we aren't caereful we'll get+If we aren't careful we'll get let $sf a co = e (K @(a |> co)) RULE "SC:f" forall a co. f (K @(a |> co)) = $sf a co
compiler/GHC/Core/Opt/Specialise.hs view
@@ -1000,7 +1000,7 @@ and similarly specialising 'g' might expose a new call to 'h'. We track the stack of enclosing functions. So when specialising 'h' we-haev a specImport call stack of [g,f]. We do this for two reasons:+have a specImport call stack of [g,f]. We do this for two reasons: * Note [Warning about missed specialisations] * Note [Avoiding recursive specialisation]
compiler/GHC/CoreToStg/Prep.hs view
@@ -855,7 +855,7 @@ -- enabled we instead produce an 'error' expression to catch -- the case where a function we think should bottom -- unexpectedly returns.- | gopt Opt_CatchBottoms (cpe_dynFlags env)+ | gopt Opt_CatchNonexhaustiveCases (cpe_dynFlags env) , not (altsAreExhaustive alts) = addDefault alts (Just err) | otherwise = alts@@ -1218,7 +1218,7 @@ The late inlining logic in cpe_app would transform this into: - (case bot of {}) realWorldPrimId#+ (case bot of {}) realWorld# Which would rise to a panic in CoreToStg.myCollectArgs, which expects only variables in function position.@@ -1451,7 +1451,7 @@ Note [Eta expansion] ~~~~~~~~~~~~~~~~~~~~~-Eta expand to match the arity claimed by the binder Remember,+Eta expand to match the arity claimed by the binder. Remember, CorePrep must not change arity Eta expansion might not have happened already, because it is done by
compiler/GHC/Driver/Backpack.hs view
@@ -183,7 +183,8 @@ , not (null insts) = sub_comp (key_base p) </> uid_str | otherwise = sub_comp (key_base p) - mk_temp_env hsc_env = hscUpdateFlags (\dflags -> mk_temp_dflags (hsc_units hsc_env) dflags) hsc_env+ mk_temp_env hsc_env =+ hscUpdateFlags (\dflags -> mk_temp_dflags (hsc_units hsc_env) dflags) hsc_env mk_temp_dflags unit_state dflags = dflags { backend = case session_type of TcSession -> NoBackend@@ -322,7 +323,7 @@ conf <- withBkpSession cid insts deps_w_rns session $ do dflags <- getDynFlags- mod_graph <- hsunitModuleGraph (unLoc lunit)+ mod_graph <- hsunitModuleGraph False (unLoc lunit) msg <- mkBackpackMsg (ok, _) <- load' [] LoadAllTargets (Just msg) mod_graph@@ -412,7 +413,7 @@ forM_ (zip [1..] deps) $ \(i, dep) -> compileInclude (length deps) (i, dep) withBkpExeSession deps_w_rns $ do- mod_graph <- hsunitModuleGraph (unLoc lunit)+ mod_graph <- hsunitModuleGraph True (unLoc lunit) msg <- mkBackpackMsg (ok, _) <- load' [] LoadAllTargets (Just msg) mod_graph when (failed ok) (liftIO $ exitWith (ExitFailure 1))@@ -432,19 +433,21 @@ , unitDatabaseUnits = [u] } in return (dbs ++ [newdb]) -- added at the end because ordering matters- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs)+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs) (hsc_all_home_unit_ids hsc_env) -- update platform constants dflags <- liftIO $ updatePlatformConstants dflags0 mconstants - let unit_env = UnitEnv+ let unit_env = ue_setUnits unit_state $ ue_setUnitDbs (Just dbs) $ UnitEnv { ue_platform = targetPlatform dflags , ue_namever = ghcNameVersion dflags- , ue_home_unit = Just home_unit- , ue_hpt = ue_hpt old_unit_env+ , ue_current_unit = homeUnitId home_unit++ , ue_home_unit_graph =+ unitEnv_singleton+ (homeUnitId home_unit)+ (mkHomeUnitEnv dflags (ue_hpt old_unit_env) (Just home_unit)) , ue_eps = ue_eps old_unit_env- , ue_units = unit_state- , ue_unit_dbs = Just dbs } setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env } @@ -565,7 +568,7 @@ msg <> showModMsg dflags (recompileRequired recomp) node <> reason in case node of- InstantiationNode _ ->+ InstantiationNode _ _ -> case recomp of MustCompile -> showMsg (text "Instantiating ") empty UpToDate@@ -573,7 +576,7 @@ | otherwise -> return () RecompBecause reason -> showMsg (text "Instantiating ") (text " [" <> pprWithUnitState state (ppr reason) <> text "]")- ModuleNode _ ->+ ModuleNode _ _ -> case recomp of MustCompile -> showMsg (text "Compiling ") empty UpToDate@@ -581,6 +584,7 @@ | otherwise -> return () RecompBecause reason -> showMsg (text "Compiling ") (text " [" <> pprWithUnitState state (ppr reason) <> text "]")+ LinkNode _ _ -> showMsg (text "Linking ") empty -- | 'PprStyle' for Backpack messages; here we usually want the module to -- be qualified (so we can tell how it was instantiated.) But we try not@@ -709,38 +713,40 @@ -- -- We don't bother trying to support GHC.Driver.Make for now, it's more trouble -- than it's worth for inline modules.-hsunitModuleGraph :: HsUnit HsComponentId -> BkpM ModuleGraph-hsunitModuleGraph unit = do+hsunitModuleGraph :: Bool -> HsUnit HsComponentId -> BkpM ModuleGraph+hsunitModuleGraph do_link unit = do hsc_env <- getSession let decls = hsunitBody unit pn = hsPackageName (unLoc (hsunitName unit)) home_unit = hsc_home_unit hsc_env + sig_keys = flip map (homeUnitInstantiations home_unit) $ \(mod_name, _) -> NodeKey_Module (ModNodeKeyWithUid (GWIB mod_name NotBoot) (homeUnitId home_unit))+ keys = [NodeKey_Module (ModNodeKeyWithUid gwib (homeUnitId home_unit)) | (DeclD hsc_src lmodname _) <- map unLoc decls, let gwib = GWIB (unLoc lmodname) (hscSourceToIsBoot hsc_src) ]+ -- 1. Create a HsSrcFile/HsigFile summary for every -- explicitly mentioned module/signature. let get_decl (L _ (DeclD hsc_src lmodname hsmod)) =- Just `fmap` summariseDecl pn hsc_src lmodname hsmod+ Just <$> summariseDecl pn hsc_src lmodname hsmod (keys ++ sig_keys) get_decl _ = return Nothing- nodes <- catMaybes `fmap` mapM get_decl decls+ nodes <- mapMaybeM get_decl decls -- 2. For each hole which does not already have an hsig file, -- create an "empty" hsig file to induce compilation for the -- requirement. let hsig_set = Set.fromList [ ms_mod_name ms- | ExtendedModSummary { emsModSummary = ms } <- nodes+ | ModuleNode _ ms <- nodes , ms_hsc_src ms == HsigFile ] req_nodes <- fmap catMaybes . forM (homeUnitInstantiations home_unit) $ \(mod_name, _) -> if Set.member mod_name hsig_set then return Nothing- else fmap (Just . extendModSummaryNoDeps) $ summariseRequirement pn mod_name- -- Using extendModSummaryNoDeps here is okay because we're making a leaf node- -- representing a signature that can't depend on any other unit.+ else fmap Just $ summariseRequirement pn mod_name - let graph_nodes = (ModuleNode <$> (nodes ++ req_nodes)) ++ (instantiationNodes (hsc_units hsc_env))+ let graph_nodes = nodes ++ req_nodes ++ (instantiationNodes (homeUnitId $ hsc_home_unit hsc_env) (hsc_units hsc_env)) key_nodes = map mkNodeKey graph_nodes+ all_nodes = graph_nodes ++ [LinkNode key_nodes (homeUnitId $ hsc_home_unit hsc_env) | do_link] -- This error message is not very good but .bkp mode is just for testing so -- better to be direct rather than pretty. when@@ -748,10 +754,10 @@ (pprPanic "Duplicate nodes keys in backpack file" (ppr key_nodes)) -- 3. Return the kaboodle- return $ mkModuleGraph' $ graph_nodes+ return $ mkModuleGraph $ all_nodes -summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary+summariseRequirement :: PackageName -> ModuleName -> BkpM ModuleGraphNode summariseRequirement pn mod_name = do hsc_env <- getSession let dflags = hsc_dflags hsc_env@@ -773,7 +779,7 @@ extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name - return ModSummary {+ let ms = ModSummary { ms_mod = mod, ms_hsc_src = HsigFile, ms_location = location,@@ -802,25 +808,29 @@ ms_hspp_opts = dflags, ms_hspp_buf = Nothing }+ let nodes = [NodeKey_Module (ModNodeKeyWithUid (GWIB mn NotBoot) (homeUnitId home_unit)) | mn <- extra_sig_imports ]+ return (ModuleNode nodes ms) summariseDecl :: PackageName -> HscSource -> Located ModuleName -> Located HsModule- -> BkpM ExtendedModSummary-summariseDecl pn hsc_src (L _ modname) hsmod = hsModuleToModSummary pn hsc_src modname hsmod+ -> [NodeKey]+ -> BkpM ModuleGraphNode+summariseDecl pn hsc_src (L _ modname) hsmod home_keys = hsModuleToModSummary home_keys pn hsc_src modname hsmod -- | Up until now, GHC has assumed a single compilation target per source file. -- Backpack files with inline modules break this model, since a single file -- may generate multiple output files. How do we decide to name these files? -- Should there only be one output file? This function our current heuristic, -- which is we make a "fake" module and use that.-hsModuleToModSummary :: PackageName+hsModuleToModSummary :: [NodeKey]+ -> PackageName -> HscSource -> ModuleName -> Located HsModule- -> BkpM ExtendedModSummary-hsModuleToModSummary pn hsc_src modname+ -> BkpM ModuleGraphNode+hsModuleToModSummary home_keys pn hsc_src modname hsmod = do let imps = hsmodImports (unLoc hsmod) loc = getLoc hsmod@@ -863,7 +873,7 @@ implicit_imports = mkPrelImports modname loc implicit_prelude imps - rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)+ rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) modname convImport (L _ i) = (rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i) extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname@@ -876,9 +886,7 @@ let home_unit = hsc_home_unit hsc_env let fc = hsc_FC hsc_env addHomeModuleToFinder fc home_unit modname location- return $ ExtendedModSummary- { emsModSummary =- ModSummary {+ let ms = ModSummary { ms_mod = this_mod, ms_hsc_src = hsc_src, ms_location = location,@@ -909,8 +917,12 @@ ms_iface_date = hi_timestamp, ms_hie_date = hie_timestamp }- , emsInstantiatedUnits = inst_deps- }++ -- Now, what are the dependencies.+ let inst_nodes = map NodeKey_Unit inst_deps+ mod_nodes = [k | (_, mnwib) <- msDeps ms, let k = NodeKey_Module (ModNodeKeyWithUid (fmap unLoc mnwib) (moduleUnitId this_mod)), k `elem` home_keys]++ return (ModuleNode (mod_nodes ++ inst_nodes) ms) -- | Create a new, externally provided hashed unit id from -- a hash.
compiler/GHC/Driver/CodeOutput.hs view
@@ -27,8 +27,9 @@ import GHC.Cmm.CLabel import GHC.Driver.Session-import GHC.Driver.Config.Finder (initFinderOpts)-import GHC.Driver.Config.CmmToAsm (initNCGConfig)+import GHC.Driver.Config.Finder (initFinderOpts)+import GHC.Driver.Config.CmmToAsm (initNCGConfig)+import GHC.Driver.Config.CmmToLlvm (initLlvmCgConfig) import GHC.Driver.Ppr import GHC.Driver.Backend @@ -187,10 +188,11 @@ -} outputLlvm :: Logger -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a-outputLlvm logger dflags filenm cmm_stream =+outputLlvm logger dflags filenm cmm_stream = do+ lcg_config <- initLlvmCgConfig logger dflags {-# SCC "llvm_output" #-} doOutput filenm $ \f -> {-# SCC "llvm_CodeGen" #-}- llvmCodeGen logger dflags f cmm_stream+ llvmCodeGen logger lcg_config f cmm_stream {- ************************************************************************
+ compiler/GHC/Driver/Config/Cmm.hs view
@@ -0,0 +1,33 @@+module GHC.Driver.Config.Cmm+ ( initCmmConfig+ ) where++import GHC.Cmm.Config+import GHC.Cmm.Switch (backendSupportsSwitch)++import GHC.Driver.Session+import GHC.Driver.Backend++import GHC.Platform++import GHC.Prelude++initCmmConfig :: DynFlags -> CmmConfig+initCmmConfig dflags = CmmConfig+ { cmmProfile = targetProfile dflags+ , cmmOptControlFlow = gopt Opt_CmmControlFlow dflags+ , cmmDoLinting = gopt Opt_DoCmmLinting dflags+ , cmmOptElimCommonBlks = gopt Opt_CmmElimCommonBlocks dflags+ , cmmOptSink = gopt Opt_CmmSink dflags+ , cmmGenStackUnwindInstr = debugLevel dflags > 0+ , cmmExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags+ , cmmDoCmmSwitchPlans = not . backendSupportsSwitch . backend $ dflags+ , cmmSplitProcPoints = (backend dflags /= NCG)+ || not (platformTablesNextToCode platform)+ || usingInconsistentPicReg+ }+ where platform = targetPlatform dflags+ usingInconsistentPicReg =+ case (platformArch platform, platformOS platform, positionIndependent dflags)+ of (ArchX86, OSDarwin, pic) -> pic+ _ -> False
compiler/GHC/Driver/Config/CmmToAsm.hs view
@@ -32,9 +32,9 @@ , ncgCfgBlockLayout = gopt Opt_CfgBlocklayout dflags , ncgCfgWeightlessLayout = gopt Opt_WeightlessBlocklayout dflags - -- With -O1 and greater, the cmmSink pass does constant-folding, so+ -- When constant-folding is enabled, the cmmSink pass does constant-folding, so -- we don't need to do it again in the native code generator.- , ncgDoConstantFolding = optLevel dflags < 1+ , ncgDoConstantFolding = not (gopt Opt_CoreConstantFolding dflags || gopt Opt_CmmSink dflags) , ncgDumpRegAllocStages = dopt Opt_D_dump_asm_regalloc_stages dflags , ncgDumpAsmStats = dopt Opt_D_dump_asm_stats dflags
+ compiler/GHC/Driver/Config/CmmToLlvm.hs view
@@ -0,0 +1,30 @@+module GHC.Driver.Config.CmmToLlvm+ ( initLlvmCgConfig+ ) where++import GHC.Prelude+import GHC.Driver.Session+import GHC.Platform+import GHC.CmmToLlvm.Config+import GHC.SysTools.Tasks+import GHC.Utils.Outputable+import GHC.Utils.Logger++-- | Initialize the Llvm code generator configuration from DynFlags+initLlvmCgConfig :: Logger -> DynFlags -> IO LlvmCgConfig+initLlvmCgConfig logger dflags = do+ version <- figureLlvmVersion logger dflags+ pure $! LlvmCgConfig {+ llvmCgPlatform = targetPlatform dflags+ , llvmCgContext = initSDocContext dflags (PprCode CStyle)+ , llvmCgFillUndefWithGarbage = gopt Opt_LlvmFillUndefWithGarbage dflags+ , llvmCgSplitSection = gopt Opt_SplitSections dflags+ , llvmCgBmiVersion = case platformArch (targetPlatform dflags) of+ ArchX86_64 -> bmiVersion dflags+ ArchX86 -> bmiVersion dflags+ _ -> Nothing+ , llvmCgLlvmVersion = version+ , llvmCgDoWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags+ , llvmCgLlvmTarget = platformMisc_llvmTarget $! platformMisc dflags+ , llvmCgLlvmConfig = llvmConfig dflags+ }
compiler/GHC/Driver/Config/Finder.hs view
@@ -7,6 +7,7 @@ import GHC.Driver.Session import GHC.Unit.Finder.Types+import GHC.Data.FastString -- | Create a new 'FinderOpts' from DynFlags.@@ -17,6 +18,10 @@ , finder_bypassHiFileCheck = MkDepend == (ghcMode flags) , finder_ways = ways flags , finder_enableSuggestions = gopt Opt_HelpfulErrors flags+ , finder_workingDirectory = workingDirectory flags+ , finder_thisPackageName = mkFastString <$> thisPackageName flags+ , finder_hiddenModules = hiddenModules flags+ , finder_reexportedModules = reexportedModules flags , finder_hieDir = hieDir flags , finder_hieSuf = hieSuf flags , finder_hiDir = hiDir flags
compiler/GHC/Driver/Main.hs view
@@ -39,9 +39,10 @@ ( -- * Making an HscEnv newHscEnv+ , newHscEnvWithHUG -- * Compiling complete source files- , Messager, batchMsg+ , Messager, batchMsg, batchMultiMsg , HscBackendAction (..), HscRecompStatus (..) , initModDetails , hscMaybeWriteIface@@ -249,14 +250,22 @@ %********************************************************************* -} newHscEnv :: DynFlags -> IO HscEnv-newHscEnv dflags = do+newHscEnv dflags = newHscEnvWithHUG dflags (homeUnitId_ dflags) home_unit_graph+ where+ home_unit_graph = unitEnv_singleton+ (homeUnitId_ dflags)+ (mkHomeUnitEnv dflags emptyHomePackageTable Nothing)++newHscEnvWithHUG :: DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv+newHscEnvWithHUG top_dynflags cur_unit home_unit_graph = do nc_var <- initNameCache 'r' knownKeyNames fc_var <- initFinderCache logger <- initLogger tmpfs <- initTmpFs- unit_env <- initUnitEnv (ghcNameVersion dflags) (targetPlatform dflags)- return HscEnv { hsc_dflags = dflags- , hsc_logger = setLogFlags logger (initLogFlags dflags)+ let dflags = homeUnitEnv_dflags $ unitEnv_lookup cur_unit home_unit_graph+ unit_env <- initUnitEnv cur_unit home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags)+ return HscEnv { hsc_dflags = top_dynflags+ , hsc_logger = setLogFlags logger (initLogFlags top_dynflags) , hsc_targets = [] , hsc_mod_graph = emptyMG , hsc_IC = emptyInteractiveContext dflags@@ -265,8 +274,7 @@ , hsc_type_env_vars = emptyKnotVars , hsc_interp = Nothing , hsc_unit_env = unit_env- , hsc_plugins = []- , hsc_static_plugins = []+ , hsc_plugins = emptyPlugins , hsc_hooks = emptyHooks , hsc_tmpfs = tmpfs }@@ -479,7 +487,7 @@ let applyPluginAction p opts = parsedResultAction p opts mod_summary hsc_env <- getHscEnv- withPlugins hsc_env applyPluginAction res+ withPlugins (hsc_plugins hsc_env) applyPluginAction res checkBidirectionFormatChars :: PsLoc -> StringBuffer -> Maybe (NonEmpty (PsLoc, Char, String)) checkBidirectionFormatChars start_loc sb@@ -729,8 +737,7 @@ = do let msg what = case mHscMessage of- -- We use extendModSummaryNoDeps because extra backpack deps are only needed for batch mode- Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode (extendModSummaryNoDeps mod_summary))+ Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode [] mod_summary) Nothing -> return () -- First check to see if the interface file agrees with the@@ -1108,31 +1115,33 @@ _ -> return () batchMsg :: Messager-batchMsg hsc_env mod_index recomp node = case node of- InstantiationNode _ ->- case recomp of- MustCompile -> showMsg (text "Instantiating ") empty- UpToDate- | logVerbAtLeast logger 2 -> showMsg (text "Skipping ") empty- | otherwise -> return ()- RecompBecause reason -> showMsg (text "Instantiating ")- (text " [" <> pprWithUnitState state (ppr reason) <> text "]")- ModuleNode _ ->- case recomp of- MustCompile -> showMsg (text "Compiling ") empty- UpToDate- | logVerbAtLeast logger 2 -> showMsg (text "Skipping ") empty- | otherwise -> return ()- RecompBecause reason -> showMsg (text "Compiling ")- (text " [" <> pprWithUnitState state (ppr reason) <> text "]")+batchMsg = batchMsgWith (\_ _ _ _ -> empty)+batchMultiMsg :: Messager+batchMultiMsg = batchMsgWith (\_ _ _ node -> brackets (ppr (moduleGraphNodeUnitId node)))++batchMsgWith :: (HscEnv -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc) -> Messager+batchMsgWith extra hsc_env_start mod_index recomp node =+ case recomp of+ MustCompile -> showMsg (text herald) empty+ UpToDate+ | logVerbAtLeast logger 2 -> showMsg (text "Skipping") empty+ | otherwise -> return ()+ RecompBecause reason -> showMsg (text herald)+ (text " [" <> pprWithUnitState state (ppr reason) <> text "]") where+ herald = case node of+ LinkNode {} -> "Linking"+ InstantiationNode {} -> "Instantiating"+ ModuleNode {} -> "Compiling"+ hsc_env = hscSetActiveUnitId (moduleGraphNodeUnitId node) hsc_env_start dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env state = hsc_units hsc_env showMsg msg reason = compilationProgressMsg logger $ (showModuleIndex mod_index <>- msg <> showModMsg dflags (recompileRequired recomp) node)+ msg <+> showModMsg dflags (recompileRequired recomp) node)+ <> extra hsc_env mod_index recomp node <> reason --------------------------------------------------------------@@ -1421,8 +1430,8 @@ hsc_env <- getHscEnv hsc_eps <- liftIO $ hscEPS hsc_env let pkgIfaceT = eps_PIT hsc_eps- homePkgT = hsc_HPT hsc_env- iface = lookupIfaceByModule homePkgT pkgIfaceT m+ hug = hsc_HUG hsc_env+ iface = lookupIfaceByModule hug pkgIfaceT m -- the 'lookupIfaceByModule' method will always fail when calling from GHCi -- as the compiler hasn't filled in the various module tables -- so we need to call 'getModuleInterface' to load from disk
compiler/GHC/Driver/Make.hs view
@@ -16,2449 +16,2545 @@ {-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ApplicativeDo #-}---- ----------------------------------------------------------------------------------- (c) The University of Glasgow, 2011------ This module implements multi-module compilation, and is used--- by --make and GHCi.------ ------------------------------------------------------------------------------module GHC.Driver.Make (- depanal, depanalE, depanalPartial,- load, loadWithCache, load', LoadHowMuch(..),- instantiationNodes,-- downsweep,-- topSortModuleGraph,-- ms_home_srcimps, ms_home_imps,-- summariseModule,- summariseFile,- hscSourceToIsBoot,- findExtraSigImports,- implicitRequirementsShallow,-- noModError, cyclicModuleErr,- SummaryNode,- IsBootInterface(..), mkNodeKey,-- ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert- ) where--import GHC.Prelude-import GHC.Platform--import GHC.Tc.Utils.Backpack-import GHC.Tc.Utils.Monad ( initIfaceCheck )--import GHC.Runtime.Interpreter-import qualified GHC.Linker.Loader as Linker-import GHC.Linker.Types--import GHC.Runtime.Context--import GHC.Driver.Config.Finder (initFinderOpts)-import GHC.Driver.Config.Parser (initParserOpts)-import GHC.Driver.Config.Diagnostic-import GHC.Driver.Phases-import GHC.Driver.Pipeline-import GHC.Driver.Session-import GHC.Driver.Backend-import GHC.Driver.Monad-import GHC.Driver.Env-import GHC.Driver.Errors-import GHC.Driver.Errors.Types-import GHC.Driver.Main--import GHC.Parser.Header--import GHC.Iface.Load ( cannotFindModule )-import GHC.IfaceToCore ( typecheckIface )-import GHC.Iface.Recomp ( RecompileRequired ( MustCompile ) )--import GHC.Data.Bag ( listToBag )-import GHC.Data.Graph.Directed-import GHC.Data.FastString-import GHC.Data.Maybe ( expectJust )-import GHC.Data.StringBuffer-import qualified GHC.LanguageExtensions as LangExt--import GHC.Utils.Exception ( throwIO, SomeAsyncException )-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Utils.Misc-import GHC.Utils.Error-import GHC.Utils.Logger-import GHC.Utils.Fingerprint-import GHC.Utils.TmpFs--import GHC.Types.Basic-import GHC.Types.Error-import GHC.Types.Target-import GHC.Types.SourceFile-import GHC.Types.SourceError-import GHC.Types.SrcLoc-import GHC.Types.Unique.FM-import GHC.Types.Unique.DSet-import GHC.Types.Unique.Set-import GHC.Types.Name-import GHC.Types.PkgQual--import GHC.Unit-import GHC.Unit.Env-import GHC.Unit.Finder-import GHC.Unit.Module.ModSummary-import GHC.Unit.Module.ModIface-import GHC.Unit.Module.ModDetails-import GHC.Unit.Module.Graph-import GHC.Unit.Home.ModInfo--import Data.Either ( rights, partitionEithers )-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified GHC.Data.FiniteMap as Map ( insertListWith )--import Control.Concurrent ( forkIO, newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask )-import qualified GHC.Conc as CC-import Control.Concurrent.MVar-import Control.Monad-import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )-import qualified Control.Monad.Catch as MC-import Data.IORef-import Data.Foldable (toList)-import Data.Maybe-import Data.Time-import Data.Bifunctor (first)-import System.Directory-import System.FilePath-import System.IO ( fixIO )--import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )-import Control.Monad.IO.Class-import Control.Monad.Trans.Reader-import GHC.Driver.Pipeline.LogQueue-import qualified Data.Map.Strict as M-import GHC.Types.TypeEnv-import Control.Monad.Trans.State.Lazy-import Control.Monad.Trans.Class-import GHC.Driver.Env.KnotVars-import Control.Concurrent.STM-import Control.Monad.Trans.Maybe-import GHC.Runtime.Loader-import GHC.Rename.Names----- -------------------------------------------------------------------------------- Loading the program---- | Perform a dependency analysis starting from the current targets--- and update the session with the new module graph.------ Dependency analysis entails parsing the @import@ directives and may--- therefore require running certain preprocessors.------ Note that each 'ModSummary' in the module graph caches its 'DynFlags'.--- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the--- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want--- changes to the 'DynFlags' to take effect you need to call this function--- again.--- In case of errors, just throw them.----depanal :: GhcMonad m =>- [ModuleName] -- ^ excluded modules- -> Bool -- ^ allow duplicate roots- -> m ModuleGraph-depanal excluded_mods allow_dup_roots = do- (errs, mod_graph) <- depanalE excluded_mods allow_dup_roots- if isEmptyMessages errs- then pure mod_graph- else throwErrors (fmap GhcDriverMessage errs)---- | Perform dependency analysis like in 'depanal'.--- In case of errors, the errors and an empty module graph are returned.-depanalE :: GhcMonad m => -- New for #17459- [ModuleName] -- ^ excluded modules- -> Bool -- ^ allow duplicate roots- -> m (DriverMessages, ModuleGraph)-depanalE excluded_mods allow_dup_roots = do- hsc_env <- getSession- (errs, mod_graph) <- depanalPartial excluded_mods allow_dup_roots- if isEmptyMessages errs- then do- let unused_home_mod_err = warnMissingHomeModules hsc_env mod_graph- unused_pkg_err = warnUnusedPackages hsc_env mod_graph- logDiagnostics (GhcDriverMessage <$> (unused_home_mod_err `unionMessages` unused_pkg_err))- setSession hsc_env { hsc_mod_graph = mod_graph }- pure (emptyMessages, mod_graph)- else do- -- We don't have a complete module dependency graph,- -- The graph may be disconnected and is unusable.- setSession hsc_env { hsc_mod_graph = emptyMG }- pure (errs, emptyMG)----- | Perform dependency analysis like 'depanal' but return a partial module--- graph even in the face of problems with some modules.------ Modules which have parse errors in the module header, failing--- preprocessors or other issues preventing them from being summarised will--- simply be absent from the returned module graph.------ Unlike 'depanal' this function will not update 'hsc_mod_graph' with the--- new module graph.-depanalPartial- :: GhcMonad m- => [ModuleName] -- ^ excluded modules- -> Bool -- ^ allow duplicate roots- -> m (DriverMessages, ModuleGraph)- -- ^ possibly empty 'Bag' of errors and a module graph.-depanalPartial excluded_mods allow_dup_roots = do- hsc_env <- getSession- let- targets = hsc_targets hsc_env- old_graph = hsc_mod_graph hsc_env- logger = hsc_logger hsc_env-- withTiming logger (text "Chasing dependencies") (const ()) $ do- liftIO $ debugTraceMsg logger 2 (hcat [- text "Chasing modules from: ",- hcat (punctuate comma (map pprTarget targets))])-- -- Home package modules may have been moved or deleted, and new- -- source files may have appeared in the home package that shadow- -- external package modules, so we have to discard the existing- -- cached finder data.- liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_home_unit hsc_env)-- mod_summariesE <- liftIO $ downsweep- hsc_env (mgExtendedModSummaries old_graph)- excluded_mods allow_dup_roots- let- (errs, mod_summaries) = partitionEithers mod_summariesE- mod_graph = mkModuleGraph' $- (instantiationNodes (hsc_units hsc_env))- ++ fmap ModuleNode mod_summaries- return (unionManyMessages errs, mod_graph)---- | Collect the instantiations of dependencies to create 'InstantiationNode' work graph nodes.--- These are used to represent the type checking that is done after--- all the free holes (sigs in current package) relevant to that instantiation--- are compiled. This is necessary to catch some instantiation errors.------ In the future, perhaps more of the work of instantiation could be moved here,--- instead of shoved in with the module compilation nodes. That could simplify--- backpack, and maybe hs-boot too.-instantiationNodes :: UnitState -> [ModuleGraphNode]-instantiationNodes unit_state = InstantiationNode <$> iuids_to_check- where- iuids_to_check :: [InstantiatedUnit]- iuids_to_check =- nubSort $ concatMap goUnitId (explicitUnits unit_state)- where- goUnitId uid =- [ recur- | VirtUnit indef <- [uid]- , inst <- instUnitInsts indef- , recur <- (indef :) $ goUnitId $ moduleUnit $ snd inst- ]---- 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`.------ Here "home module" means a module, that doesn't come from an other 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.------ The warning in enabled by `-Wmissing-home-modules`. See #13129-warnMissingHomeModules :: HscEnv -> ModuleGraph -> DriverMessages-warnMissingHomeModules hsc_env mod_graph =- if null missing- then emptyMessages- else warn- where- dflags = hsc_dflags hsc_env- targets = map targetId (hsc_targets hsc_env)- 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.- --- -- For instance, `ghc --make src-exe/Main.hs` and- -- `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 (TargetModule name)- = moduleName (ms_mod mod) == name- is_my_target mod (TargetFile target_file _)- | Just mod_file <- ml_hs_file (ms_location mod)- = target_file == mod_file ||-- -- Don't warn on B.hs-boot if B.hs is specified (#16551)- addBootSuffix target_file == mod_file ||-- -- 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)- is_my_target _ _ = False-- missing = map (moduleName . ms_mod) $- filter (not . is_known_module) (mgModSummaries mod_graph)-- warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan- $ DriverMissingHomeModules missing (checkBuildingCabalPackage dflags)---- | Describes which modules of the module graph need to be loaded.-data LoadHowMuch- = LoadAllTargets- -- ^ Load all targets and its dependencies.- | LoadUpTo ModuleName- -- ^ Load only the given module and its dependencies.- | LoadDependenciesOf ModuleName- -- ^ Load only the dependencies of the given module, but not the module- -- itself.---- | Try to load the program. See 'LoadHowMuch' for the different modes.------ This function implements the core of GHC's @--make@ mode. It preprocesses,--- compiles and loads the specified modules, avoiding re-compilation wherever--- possible. Depending on the backend (see 'DynFlags.backend' field) compiling--- and loading may result in files being created on disk.------ Calls the 'defaultWarnErrLogger' after each compiling each module, whether--- successful or not.------ If errors are encountered during dependency analysis, the module `depanalE`--- returns together with the errors an empty ModuleGraph.--- After processing this empty ModuleGraph, the errors of depanalE are thrown.--- All other errors are reported using the 'defaultWarnErrLogger'.--load :: GhcMonad f => LoadHowMuch -> f SuccessFlag-load how_much = fst <$> loadWithCache [] how_much--loadWithCache :: GhcMonad m => [HomeModInfo] -> LoadHowMuch -> m (SuccessFlag, [HomeModInfo])-loadWithCache cache how_much = do- (errs, mod_graph) <- depanalE [] False -- #17459- success <- load' cache how_much (Just batchMsg) mod_graph- if isEmptyMessages errs- then pure success- else throwErrors (fmap GhcDriverMessage errs)---- Note [Unused packages]------ Cabal passes `--package-id` flag for each direct dependency. But GHC--- loads them lazily, so when compilation is done, we have a list of all--- actually loaded packages. All the packages, specified on command line,--- but never loaded, are probably unused dependencies.--warnUnusedPackages :: HscEnv -> ModuleGraph -> DriverMessages-warnUnusedPackages hsc_env mod_graph =- let dflags = hsc_dflags hsc_env- state = hsc_units hsc_env- diag_opts = initDiagOpts dflags- us = hsc_units hsc_env-- -- Only need non-source imports here because SOURCE imports are always HPT- loadedPackages = concat $- mapMaybe (\(fs, mn) -> lookupModulePackage us (unLoc mn) fs)- $ concatMap ms_imps (mgModSummaries mod_graph)-- requestedArgs = mapMaybe packageArg (packageFlags dflags)-- unusedArgs- = filter (\arg -> not $ any (matching state arg) loadedPackages)- requestedArgs-- warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan (DriverUnusedPackages unusedArgs)-- in if null unusedArgs- then emptyMessages- else warn-- where- packageArg (ExposePackage _ arg _) = Just arg- packageArg _ = Nothing-- matchingStr :: String -> UnitInfo -> Bool- matchingStr str p- = str == unitPackageIdString p- || str == unitPackageNameString p-- matching :: UnitState -> PackageArg -> UnitInfo -> Bool- matching _ (PackageArg str) p = matchingStr str p- matching state (UnitIdArg uid) p = uid == realUnit state p-- -- For wired-in packages, we have to unwire their id,- -- otherwise they won't match package flags- realUnit :: UnitState -> UnitInfo -> Unit- realUnit state- = unwireUnit state- . RealUnit- . Definite- . unitId----- | A ModuleGraphNode which also has a hs-boot file, and the list of nodes on any--- path from module to its boot file.-data ModuleGraphNodeWithBootFile- = ModuleGraphNodeWithBootFile ModuleGraphNode [ModuleGraphNode]--instance Outputable ModuleGraphNodeWithBootFile where- ppr (ModuleGraphNodeWithBootFile mgn deps) = text "ModeGraphNodeWithBootFile: " <+> ppr mgn $$ ppr deps--getNode :: ModuleGraphNodeWithBootFile -> ModuleGraphNode-getNode (ModuleGraphNodeWithBootFile mgn _) = mgn-data BuildPlan = SingleModule ModuleGraphNode -- A simple, single module all alone but *might* have an hs-boot file which isn't part of a cycle- | ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile] -- A resolved cycle, linearised by hs-boot files- | UnresolvedCycle [ModuleGraphNode] -- An actual cycle, which wasn't resolved by hs-boot files--instance Outputable BuildPlan where- ppr (SingleModule mgn) = text "SingleModule" <> parens (ppr mgn)- ppr (ResolvedCycle mgn) = text "ResolvedCycle:" <+> ppr mgn- ppr (UnresolvedCycle mgn) = text "UnresolvedCycle:" <+> ppr mgn----- Just used for an assertion-countMods :: BuildPlan -> Int-countMods (SingleModule _) = 1-countMods (ResolvedCycle ns) = length ns-countMods (UnresolvedCycle ns) = length ns---- See Note [Upsweep] for a high-level description.-createBuildPlan :: ModuleGraph -> Maybe ModuleName -> [BuildPlan]-createBuildPlan mod_graph maybe_top_mod =- let -- Step 1: Compute SCCs without .hi-boot files, to find the cycles- cycle_mod_graph = topSortModuleGraph True mod_graph maybe_top_mod-- -- Step 2: Reanalyse loops, with relevant boot modules, to solve the cycles.- build_plan :: [BuildPlan]- build_plan- -- Fast path, if there are no boot modules just do a normal toposort- | isEmptyModuleEnv boot_modules = collapseAcyclic $ topSortModuleGraph False mod_graph maybe_top_mod- | otherwise = toBuildPlan cycle_mod_graph []-- toBuildPlan :: [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan]- toBuildPlan [] mgn = collapseAcyclic (topSortWithBoot mgn)- toBuildPlan ((AcyclicSCC node):sccs) mgn = toBuildPlan sccs (node:mgn)- -- Interesting case- toBuildPlan ((CyclicSCC nodes):sccs) mgn =- let acyclic = collapseAcyclic (topSortWithBoot mgn)- -- Now perform another toposort but just with these nodes and relevant hs-boot files.- -- The result should be acyclic, if it's not, then there's an unresolved cycle in the graph.- mresolved_cycle = collapseSCC (topSortWithBoot nodes)- in acyclic ++ [maybe (UnresolvedCycle nodes) ResolvedCycle mresolved_cycle] ++ toBuildPlan sccs []-- (mg, lookup_node) = moduleGraphNodes False (mgModSummaries' mod_graph)- trans_deps_map = allReachable mg (mkNodeKey . node_payload)- boot_path mn =- map (summaryNodeSummary . expectJust "toNode" . lookup_node) $ Set.toList $- Set.delete (NodeKey_Module (GWIB mn IsBoot)) $- expectJust "boot_path" (M.lookup (NodeKey_Module (GWIB mn NotBoot)) trans_deps_map)- `Set.difference` (expectJust "boot_path" (M.lookup (NodeKey_Module (GWIB mn IsBoot)) trans_deps_map))--- -- An environment mapping a module to its hs-boot file and all nodes on the path between the two, if one exists- boot_modules = mkModuleEnv- [ (ms_mod ms, (m, boot_path (ms_mod_name ms))) | m@(ModuleNode (ExtendedModSummary ms _)) <- (mgModSummaries' mod_graph), isBootSummary ms == IsBoot]-- select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode]- select_boot_modules = mapMaybe (fmap fst . get_boot_module)-- get_boot_module :: (ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode]))- get_boot_module m = case m of ModuleNode (ExtendedModSummary ms _) | HsSrcFile <- ms_hsc_src ms -> lookupModuleEnv boot_modules (ms_mod ms); _ -> Nothing-- -- Any cycles should be resolved now- collapseSCC :: [SCC ModuleGraphNode] -> Maybe [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)]- -- Must be at least two nodes, as we were in a cycle- collapseSCC [AcyclicSCC node1, AcyclicSCC node2] = Just [toNodeWithBoot node1, toNodeWithBoot node2]- collapseSCC (AcyclicSCC node : nodes) = (toNodeWithBoot node :) <$> collapseSCC nodes- -- Cyclic- collapseSCC _ = Nothing-- toNodeWithBoot :: (ModuleGraphNode -> Either ModuleGraphNode ModuleGraphNodeWithBootFile)- toNodeWithBoot mn =- case get_boot_module mn of- -- The node doesn't have a boot file- Nothing -> Left mn- -- The node does have a boot file- Just path -> Right (ModuleGraphNodeWithBootFile mn (snd path))-- -- The toposort and accumulation of acyclic modules is solely to pick-up- -- hs-boot files which are **not** part of cycles.- collapseAcyclic :: [SCC ModuleGraphNode] -> [BuildPlan]- collapseAcyclic (AcyclicSCC node : nodes) = SingleModule node : collapseAcyclic nodes- collapseAcyclic (CyclicSCC cy_nodes : nodes) = (UnresolvedCycle cy_nodes) : collapseAcyclic nodes- collapseAcyclic [] = []-- topSortWithBoot nodes = topSortModules False (select_boot_modules nodes ++ nodes) Nothing--- in-- assertPpr (sum (map countMods build_plan) == length (mgModSummaries' mod_graph))- (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr build_plan), (text "GRAPH:" <+> ppr (mgModSummaries' mod_graph ))])- build_plan---- | Generalized version of 'load' which also supports a custom--- 'Messager' (for reporting progress) and 'ModuleGraph' (generally--- produced by calling 'depanal'.-load' :: GhcMonad m => [HomeModInfo] -> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m (SuccessFlag, [HomeModInfo])-load' cache how_much mHscMessage mod_graph = do- modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph }- guessOutputFile- hsc_env <- getSession-- let dflags = hsc_dflags hsc_env- let logger = hsc_logger hsc_env- let interp = hscInterp hsc_env-- -- The "bad" boot modules are the ones for which we have- -- B.hs-boot in the module graph, but no B.hs- -- The downsweep should have ensured this does not happen- -- (see msDeps)- let all_home_mods =- mkUniqSet [ ms_mod_name s- | s <- mgModSummaries mod_graph, isBootSummary s == NotBoot]- -- TODO: Figure out what the correct form of this assert is. It's violated- -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot- -- files without corresponding hs files.- -- bad_boot_mods = [s | s <- mod_graph, isBootSummary s,- -- not (ms_mod_name s `elem` all_home_mods)]- -- assert (null bad_boot_mods ) return ()-- -- check that the module given in HowMuch actually exists, otherwise- -- topSortModuleGraph will bomb later.- let checkHowMuch (LoadUpTo m) = checkMod m- checkHowMuch (LoadDependenciesOf m) = checkMod m- checkHowMuch _ = id-- checkMod m and_then- | m `elementOfUniqSet` all_home_mods = and_then- | otherwise = do- liftIO $ errorMsg logger- (text "no such module:" <+> quotes (ppr m))- return (Failed, [])-- checkHowMuch how_much $ do-- -- mg2_with_srcimps drops the hi-boot nodes, returning a- -- graph with cycles. It is just used for warning about unecessary source imports.- let mg2_with_srcimps :: [SCC ModuleGraphNode]- mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing-- -- If we can determine that any of the {-# SOURCE #-} imports- -- are definitely unnecessary, then emit a warning.- warnUnnecessarySourceImports (filterToposortToModules mg2_with_srcimps)-- let maybe_top_mod = case how_much of- LoadUpTo m -> Just m- LoadDependenciesOf m -> Just m- _ -> Nothing-- build_plan = createBuildPlan mod_graph maybe_top_mod----- let- -- prune the HPT so everything is not retained when doing an- -- upsweep.- !pruned_cache = pruneCache cache- (flattenSCCs (filterToposortToModules mg2_with_srcimps))--- -- before we unload anything, make sure we don't leave an old- -- interactive context around pointing to dead bindings. Also,- -- write an empty HPT to allow the old HPT to be GC'd.- setSession $ discardIC $ hscUpdateHPT (const emptyHomePackageTable) hsc_env-- -- Unload everything- liftIO $ unload interp hsc_env-- liftIO $ debugTraceMsg logger 2 (hang (text "Ready for upsweep")- 2 (ppr build_plan))-- let direct_deps = mkDepsMap (mgModSummaries' mod_graph)-- n_jobs <- case parMakeCount dflags of- Nothing -> liftIO getNumProcessors- Just n -> return n-- setSession $ hscUpdateHPT (const emptyHomePackageTable) hsc_env- hsc_env <- getSession- (upsweep_ok, hsc_env1, new_cache) <- withDeferredDiagnostics $- liftIO $ upsweep n_jobs hsc_env mHscMessage (toCache pruned_cache) direct_deps build_plan- setSession hsc_env1- fmap (, new_cache) $ case upsweep_ok of- Failed -> loadFinish upsweep_ok Succeeded-- Succeeded -> do- -- Make modsDone be the summaries for each home module now- -- available; this should equal the domain of hpt3.- -- Get in in a roughly top .. bottom order (hence reverse).-- -- Try and do linking in some form, depending on whether the- -- upsweep was completely or only partially successful.-- -- Easy; just relink it all.- do liftIO $ debugTraceMsg logger 2 (text "Upsweep completely successful.")-- -- Clean up after ourselves- hsc_env1 <- getSession- liftIO $ cleanCurrentModuleTempFilesMaybe logger (hsc_tmpfs hsc_env1) dflags-- -- Issue a warning for the confusing case where the user- -- said '-o foo' but we're not going to do any linking.- -- We attempt linking if either (a) one of the modules is- -- called Main, or (b) the user said -no-hs-main, indicating- -- that main() is going to come from somewhere else.- --- let ofile = outputFile_ dflags- let no_hs_main = gopt Opt_NoHsMain dflags- let- main_mod = mainModIs hsc_env- a_root_is_Main = mgElemModule mod_graph main_mod- do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib-- -- link everything together- hsc_env <- getSession- linkresult <- liftIO $ link (ghcLink dflags)- logger- (hsc_tmpfs hsc_env)- (hsc_hooks hsc_env)- dflags- (hsc_unit_env hsc_env)- do_linking- (hsc_HPT hsc_env1)-- if ghcLink dflags == LinkBinary && isJust ofile && not do_linking- then do- liftIO $ errorMsg logger $ text- ("output was redirected with -o, " ++- "but no output will be generated\n" ++- "because there is no " ++- moduleNameString (moduleName main_mod) ++ " module.")- -- This should be an error, not a warning (#10895).- loadFinish Failed linkresult- else- loadFinish Succeeded linkresult--partitionNodes- :: [ModuleGraphNode]- -> ( [InstantiatedUnit]- , [ExtendedModSummary]- )-partitionNodes ns = partitionEithers $ flip fmap ns $ \case- InstantiationNode x -> Left x- ModuleNode x -> Right x---- | Finish up after a load.-loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag---- If the link failed, unload everything and return.-loadFinish _all_ok Failed- = do hsc_env <- getSession- let interp = hscInterp hsc_env- liftIO $ unload interp hsc_env- modifySession discardProg- return Failed---- Empty the interactive context and set the module context to the topmost--- newly loaded module, or the Prelude if none were loaded.-loadFinish all_ok Succeeded- = do modifySession discardIC- return all_ok----- | Forget the current program, but retain the persistent info in HscEnv-discardProg :: HscEnv -> HscEnv-discardProg hsc_env- = discardIC- $ hscUpdateHPT (const emptyHomePackageTable)- $ hsc_env { hsc_mod_graph = emptyMG }---- | Discard the contents of the InteractiveContext, but keep the DynFlags and--- the loaded plugins. It will also keep ic_int_print and ic_monad if their--- names are from external packages.-discardIC :: HscEnv -> HscEnv-discardIC hsc_env- = hsc_env { hsc_IC = empty_ic { ic_int_print = new_ic_int_print- , ic_monad = new_ic_monad- , ic_plugins = old_plugins- } }- where- -- Force the new values for ic_int_print and ic_monad to avoid leaking old_ic- !new_ic_int_print = keep_external_name ic_int_print- !new_ic_monad = keep_external_name ic_monad- !old_plugins = ic_plugins old_ic- dflags = ic_dflags old_ic- old_ic = hsc_IC hsc_env- empty_ic = emptyInteractiveContext dflags- keep_external_name ic_name- | nameIsFromExternalPackage home_unit old_name = old_name- | otherwise = ic_name empty_ic- where- home_unit = hsc_home_unit hsc_env- old_name = ic_name old_ic---- | If there is no -o option, guess the name of target executable--- by using top-level source file name as a base.-guessOutputFile :: GhcMonad m => m ()-guessOutputFile = modifySession $ \env ->- let dflags = hsc_dflags env- platform = targetPlatform dflags- -- Force mod_graph to avoid leaking env- !mod_graph = hsc_mod_graph env- mainModuleSrcPath :: Maybe String- mainModuleSrcPath = do- ms <- mgLookupModule mod_graph (mainModIs env)- ml_hs_file (ms_location ms)- name = fmap dropExtension mainModuleSrcPath-- !name_exe = do- -- we must add the .exe extension unconditionally here, otherwise- -- when name has an extension of its own, the .exe extension will- -- not be added by GHC.Driver.Pipeline.exeFileName. See #2248- !name' <- if platformOS platform == OSMinGW32- then fmap (<.> "exe") name- else name- mainModuleSrcPath' <- mainModuleSrcPath- -- #9930: don't clobber input files (unless they ask for it)- if name' == mainModuleSrcPath'- then throwGhcException . UsageError $- "default output name would overwrite the input file; " ++- "must specify -o explicitly"- else Just name'- in- case outputFile_ dflags of- Just _ -> env- Nothing -> hscSetFlags (dflags { outputFile_ = name_exe }) env---- ----------------------------------------------------------------------------------- | Prune the HomePackageTable------ Before doing an upsweep, we can throw away:------ - all ModDetails, all linked code--- - all unlinked code that is out of date with respect to--- the source file------ This is VERY IMPORTANT otherwise we'll end up requiring 2x the--- space at the end of the upsweep, because the topmost ModDetails of the--- old HPT holds on to the entire type environment from the previous--- compilation.--- Note [GHC Heap Invariants]-pruneCache :: [HomeModInfo]- -> [ModSummary]- -> [HomeModInfo]-pruneCache hpt summ- = strictMap prune hpt- where prune hmi = hmi'{ hm_details = emptyModDetails }- where- modl = moduleName (mi_module (hm_iface hmi))- hmi' | Just ms <- lookupUFM ms_map modl- , mi_src_hash (hm_iface hmi) /= ms_hs_hash ms- = hmi{ hm_linkable = Nothing }- | otherwise- = hmi-- ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]---- --------------------------------------------------------------------------------- | Unloading-unload :: Interp -> HscEnv -> IO ()-unload interp hsc_env- = case ghcLink (hsc_dflags hsc_env) of- LinkInMemory -> Linker.unload interp hsc_env []- _other -> return ()---{- Parallel Upsweep--The parallel upsweep attempts to concurrently compile the modules in the-compilation graph using multiple Haskell threads.--The Algorithm--* The list of `MakeAction`s are created by `interpretBuildPlan`. A `MakeAction` is-a pair of an `IO a` action and a `MVar a`, where to place the result.- The list is sorted topologically, so can be executed in order without fear of- blocking.-* runPipelines takes this list and eventually passes it to runLoop which executes- each action and places the result into the right MVar.-* The amount of parrelism is controlled by a semaphore. This is just used around the- module compilation step, so that only the right number of modules are compiled at- the same time which reduces overal memory usage and allocations.-* Each proper node has a LogQueue, which dictates where to send it's output.-* The LogQueue is placed into the LogQueueQueue when the action starts and a worker- thread processes the LogQueueQueue printing logs for each module in a stable order.-* The result variable for an action producing `a` is of type `Maybe a`, therefore- it is still filled on a failure. If a module fails to compile, the- failure is propagated through the whole module graph and any modules which didn't- depend on the failure can still be compiled. This behaviour also makes the code- quite a bit cleaner.--}---{---Note [--make mode]-~~~~~~~~~~~~~~~~~--There are two main parts to `--make` mode.--1. `downsweep`: Starts from the top of the module graph and computes dependencies.-2. `upsweep`: Starts from the bottom of the module graph and compiles modules.--The result of the downsweep is a 'ModuleGraph', which is then passed to 'upsweep' which-computers how to build this ModuleGraph.--Note [Upsweep]-~~~~~~~~~~~~~~--Upsweep takes a 'ModuleGraph' as input, computes a build plan and then executes-the plan in order to compile the project.--The first step is computing the build plan from a 'ModuleGraph'.--The output of this step is a `[BuildPlan]`, which is a topologically sorted plan for-how to build all the modules.--```-data BuildPlan = SingleModule ModuleGraphNode -- A simple, single module all alone but *might* have an hs-boot file which isn't part of a cycle- | ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBoot] -- A resolved cycle, linearised by hs-boot files- | UnresolvedCycle [ModuleGraphNode] -- An actual cycle, which wasn't resolved by hs-boot files-```--The plan is computed in two steps:--Step 1: Topologically sort the module graph without hs-boot files. This returns a [SCC ModuleGraphNode] which contains- cycles.-Step 2: For each cycle, topologically sort the modules in the cycle *with* the relevant hs-boot files. This should- result in an acyclic build plan if the hs-boot files are sufficient to resolve the cycle.-Step 2a: For each module in the cycle, if the module has a boot file then compute the- modules on the path between it and the hs-boot file. This information is- stored in ModuleGraphNodeWithBoot.--The `[BuildPlan]` is then interpreted by the `interpretBuildPlan` function.--* SingleModule nodes are compiled normally by either the upsweep_inst or upsweep_mod functions.-* ResolvedCycles need to compiled "together" so that modules outside the cycle are presented- with a consistent knot-tied version of modules at the end.- - When the ModuleGraphNodeWithBoot nodes are compiled then suitable rehydration- is performed both before and after the module in question is compiled.- See Note [Hydrating Modules] for more information.-* UnresolvedCycles are indicative of a proper cycle, unresolved by hs-boot files- and are reported as an error to the user.--The main trickiness of `interpretBuildPlan` is deciding which version of a dependency-is visible from each module. For modules which are not in a cycle, there is just-one version of a module, so that is always used. For modules in a cycle, there are two versions of-'HomeModInfo'.--1. Internal to loop: The version created whilst compiling the loop by upsweep_mod.-2. External to loop: The knot-tied version created by typecheckLoop.--Whilst compiling a module inside the loop, we need to use the (1). For a module which-is outside of the loop which depends on something from in the loop, the (2) version-is used.--As the plan is interpreted, which version of a HomeModInfo is visible is updated-by updating a map held in a state monad. So after a loop has finished being compiled,-the visible module is the one created by typecheckLoop and the internal version is not-used again.--This plan also ensures the most important invariant to do with module loops:--> If you depend on anything within a module loop, before you can use the dependency,- the whole loop has to finish compiling.--The end result of `interpretBuildPlan` is a `[MakeAction]`, which are pairs-of `IO a` actions and a `MVar (Maybe a)`, somewhere to put the result of running-the action. This list is topologically sorted, so can be run in order to compute-the whole graph.--As well as this `interpretBuildPlan` also outputs an `IO [Maybe (Maybe HomeModInfo)]` which-can be queried at the end to get the result of all modules at the end, with their proper-visibility. For example, if any module in a loop fails then all modules in that loop will-report as failed because the visible node at the end will be the result of checking-these modules together.---}---- | Simple wrapper around MVar which allows a functor instance.-data ResultVar b = forall a . ResultVar (a -> b) (MVar (Maybe a))--instance Functor ResultVar where- fmap f (ResultVar g var) = ResultVar (f . g) var--mkResultVar :: MVar (Maybe a) -> ResultVar a-mkResultVar = ResultVar id---- | Block until the result is ready.-waitResult :: ResultVar a -> MaybeT IO a-waitResult (ResultVar f var) = MaybeT (fmap f <$> readMVar var)---data BuildLoopState = BuildLoopState { buildDep :: M.Map NodeKey (SDoc, ResultVar (Maybe HomeModInfo))- -- The current way to build a specific TNodeKey, without cycles this just points to- -- the appropiate result of compiling a module but with- -- cycles there can be additional indirection and can point to the result of typechecking a loop- , nNODE :: Int- , hpt_var :: MVar HomePackageTable- -- A global variable which is incrementally updated with the result- -- of compiling modules.- }--nodeId :: BuildM Int-nodeId = do- n <- gets nNODE- modify (\m -> m { nNODE = n + 1 })- return n--setModulePipeline :: NodeKey -> SDoc -> ResultVar (Maybe HomeModInfo) -> BuildM ()-setModulePipeline mgn doc wrapped_pipeline = do- modify (\m -> m { buildDep = M.insert mgn (doc, wrapped_pipeline) (buildDep m) })--getBuildMap :: BuildM (M.Map- NodeKey (SDoc, ResultVar (Maybe HomeModInfo)))-getBuildMap = gets buildDep--type BuildM a = StateT BuildLoopState IO a----- | Abstraction over the operations of a semaphore which allows usage with the--- -j1 case-data AbstractSem = AbstractSem { acquireSem :: IO ()- , releaseSem :: IO () }--withAbstractSem :: AbstractSem -> IO b -> IO b-withAbstractSem sem = MC.bracket_ (acquireSem sem) (releaseSem sem)---- | Environment used when compiling a module-data MakeEnv = MakeEnv { hsc_env :: !HscEnv -- The basic HscEnv which will be augmented for each module- , compile_sem :: !AbstractSem- -- Modify the environment for module k, with the supplied logger modification function.- -- For -j1, this wrapper doesn't do anything- -- For -jn, the wrapper initialised a log queue and then modifies the logger to pipe its output- -- into the log queue.- , withLogger :: forall a . Int -> ((Logger -> Logger) -> RunMakeM a) -> RunMakeM a- , env_messager :: !(Maybe Messager)- }--type RunMakeM a = ReaderT MakeEnv (MaybeT IO) a---- | Given the build plan, creates a graph which indicates where each NodeKey should--- get its direct dependencies from. This might not be the corresponding build action--- if the module participates in a loop. This step also labels each node with a number for the output.--- See Note [Upsweep] for a high-level description.-interpretBuildPlan :: (M.Map ModuleNameWithIsBoot HomeModInfo)- -> (NodeKey -> [NodeKey])- -> [BuildPlan]- -> IO ( Maybe [ModuleGraphNode] -- Is there an unresolved cycle- , [MakeAction] -- Actions we need to run in order to build everything- , IO [Maybe (Maybe HomeModInfo)]) -- An action to query to get all the built modules at the end.-interpretBuildPlan old_hpt deps_map plan = do- hpt_var <- newMVar emptyHomePackageTable- ((mcycle, plans), build_map) <- runStateT (buildLoop plan) (BuildLoopState M.empty 1 hpt_var)- return (mcycle, plans, collect_results (buildDep build_map))-- where- collect_results build_map = mapM (\(_doc, res_var) -> runMaybeT (waitResult res_var)) (M.elems build_map)-- n_mods = sum (map countMods plan)-- buildLoop :: [BuildPlan]- -> BuildM (Maybe [ModuleGraphNode], [MakeAction])- -- Build the abstract pipeline which we can execute- -- Building finished- buildLoop [] = return (Nothing, [])- buildLoop (plan:plans) =- case plan of- -- If there was no cycle, then typecheckLoop is not necessary- SingleModule m -> do- (one_plan, _) <- buildSingleModule Nothing m- (cycle, all_plans) <- buildLoop plans- return (cycle, one_plan : all_plans)-- -- For a resolved cycle, depend on everything in the loop, then update- -- the cache to point to this node rather than directly to the module build- -- nodes- ResolvedCycle ms -> do- pipes <- buildModuleLoop ms- (cycle, graph) <- buildLoop plans- return (cycle, pipes ++ graph)-- -- Can't continue past this point as the cycle is unresolved.- UnresolvedCycle ns -> return (Just ns, [])-- buildSingleModule :: Maybe [ModuleGraphNode] -- Modules we need to rehydrate before compiling this module- -> ModuleGraphNode -- The node we are compiling- -> BuildM (MakeAction, ResultVar (Maybe HomeModInfo))- buildSingleModule rehydrate_nodes mod = do- mod_idx <- nodeId- home_mod_map <- getBuildMap- hpt_var <- gets hpt_var- -- 1. Get the transitive dependencies of this module, by looking up in the dependency map- let direct_deps = deps_map (mkNodeKey mod)- doc_build_deps = catMaybes $ map (flip M.lookup home_mod_map) direct_deps- build_deps = map snd doc_build_deps- -- 2. Set the default way to build this node, not in a loop here- let build_action = do- hsc_env <- asks hsc_env- case mod of- InstantiationNode iu -> const Nothing <$> executeInstantiationNode mod_idx n_mods (wait_deps_hpt hpt_var build_deps) iu- ModuleNode ms -> do- let !old_hmi = M.lookup (msKey $ emsModSummary ms) old_hpt- rehydrate_mods = mapMaybe moduleGraphNodeModule <$> rehydrate_nodes- hmi <- executeCompileNode mod_idx n_mods old_hmi (wait_deps_hpt hpt_var build_deps) rehydrate_mods (emsModSummary ms)- -- This global MVar is incrementally modified in order to avoid having to- -- recreate the HPT before compiling each module which leads to a quadratic amount of work.- hmi' <- liftIO $ modifyMVar hpt_var (\hpt -> do- let new_hpt = addHomeModInfoToHpt hmi hpt- new_hsc = setHPT new_hpt hsc_env- maybeRehydrateAfter hmi new_hsc rehydrate_mods- )- return (Just hmi')-- res_var <- liftIO newEmptyMVar- let result_var = mkResultVar res_var- setModulePipeline (mkNodeKey mod) (text "N") result_var- return $ (MakeAction build_action res_var, result_var)--- buildOneLoopyModule :: ModuleGraphNodeWithBootFile -> BuildM (MakeAction, (ResultVar (Maybe HomeModInfo)))- buildOneLoopyModule (ModuleGraphNodeWithBootFile mn deps) =- buildSingleModule (Just deps) mn-- buildModuleLoop :: [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)] -> BuildM [MakeAction]- buildModuleLoop ms = do- (build_modules, wait_modules) <- mapAndUnzipM (either (buildSingleModule Nothing) buildOneLoopyModule) ms- res_var <- liftIO newEmptyMVar- let loop_action = wait_deps wait_modules- let fanout i = Just . (!! i) <$> mkResultVar res_var- -- From outside the module loop, anyone must wait for the loop to finish and then- -- use the result of the rehydrated iface. This makes sure that things not in the- -- module loop will see the updated interfaces for all the identifiers in the loop.- let update_module_pipeline (m, i) = setModulePipeline (NodeKey_Module m) (text "T") (fanout i)-- let ms_i = zip (mapMaybe (fmap (msKey . emsModSummary) . moduleGraphNodeModSum . either id getNode) ms) [0..]- mapM update_module_pipeline ms_i- return $ build_modules ++ [MakeAction loop_action res_var]---upsweep- :: Int -- ^ The number of workers we wish to run in parallel- -> HscEnv -- ^ The base HscEnv, which is augmented for each module- -> Maybe Messager- -> M.Map ModuleNameWithIsBoot HomeModInfo- -> (NodeKey -> [NodeKey]) -- A function which computes the direct dependencies of a NodeKey- -> [BuildPlan]- -> IO (SuccessFlag, HscEnv, [HomeModInfo])-upsweep n_jobs hsc_env mHscMessage old_hpt direct_deps build_plan = do- (cycle, pipelines, collect_result) <- interpretBuildPlan old_hpt direct_deps build_plan- runPipelines n_jobs hsc_env mHscMessage pipelines- res <- collect_result-- let completed = [m | Just (Just m) <- res]- let hsc_env' = addDepsToHscEnv completed hsc_env-- -- Handle any cycle in the original compilation graph and return the result- -- of the upsweep.- case cycle of- Just mss -> do- let logger = hsc_logger hsc_env- liftIO $ fatalErrorMsg logger (cyclicModuleErr mss)- return (Failed, hsc_env, completed)- Nothing -> do- let success_flag = successIf (all isJust res)- return (success_flag, hsc_env', completed)--toCache :: [HomeModInfo] -> M.Map ModuleNameWithIsBoot HomeModInfo-toCache hmis = M.fromList ([(mi_mnwib $ hm_iface hmi, hmi) | hmi <- hmis])--upsweep_inst :: HscEnv- -> Maybe Messager- -> Int -- index of module- -> Int -- total number of modules- -> InstantiatedUnit- -> IO ()-upsweep_inst hsc_env mHscMessage mod_index nmods iuid = do- case mHscMessage of- Just hscMessage -> hscMessage hsc_env (mod_index, nmods) MustCompile (InstantiationNode iuid)- Nothing -> return ()- runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ tcRnCheckUnit hsc_env $ VirtUnit iuid- pure ()---- | Compile a single module. Always produce a Linkable for it if--- successful. If no compilation happened, return the old Linkable.-upsweep_mod :: HscEnv- -> Maybe Messager- -> Maybe HomeModInfo- -> ModSummary- -> Int -- index of module- -> Int -- total number of modules- -> IO HomeModInfo-upsweep_mod hsc_env mHscMessage old_hmi summary mod_index nmods = do- hmi <- compileOne' mHscMessage hsc_env summary- mod_index nmods (hm_iface <$> old_hmi) (old_hmi >>= hm_linkable)-- -- MP: This is a bit janky, because before you add the entries you have to extend the HPT with the module- -- you just compiled. Another option, would be delay adding anything until after upsweep has finished, but I- -- am unsure if this is sound (wrt running TH splices for example).- -- This function only does anything if the linkable produced is a BCO, which only happens with the- -- bytecode backend, no need to guard against the backend type additionally.- addSptEntries (hscUpdateHPT (\hpt -> addToHpt hpt (ms_mod_name summary) hmi) hsc_env)- (ms_mnwib summary)- (hm_linkable hmi)-- return hmi---- | Add the entries from a BCO linkable to the SPT table, see--- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.-addSptEntries :: HscEnv -> ModuleNameWithIsBoot -> Maybe Linkable -> IO ()-addSptEntries hsc_env mnwib mlinkable =- hscAddSptEntries hsc_env (Just mnwib)- [ spt- | Just linkable <- [mlinkable]- , unlinked <- linkableUnlinked linkable- , BCOs _ spts <- pure unlinked- , spt <- spts- ]--{- Note [-fno-code mode]-~~~~~~~~~~~~~~~~~~~~~~~~-GHC offers the flag -fno-code for the purpose of parsing and typechecking a-program without generating object files. This is intended to be used by tooling-and IDEs to provide quick feedback on any parser or type errors as cheaply as-possible.--When GHC is invoked with -fno-code no object files or linked output will be-generated. As many errors and warnings as possible will be generated, as if--fno-code had not been passed. The session DynFlags will have-backend == NoBackend.---fwrite-interface-~~~~~~~~~~~~~~~~-Whether interface files are generated in -fno-code mode is controlled by the--fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is-not also passed. Recompilation avoidance requires interface files, so passing--fno-code without -fwrite-interface should be avoided. If -fno-code were-re-implemented today, -fwrite-interface would be discarded and it would be-considered always on; this behaviour is as it is for backwards compatibility.--================================================================-IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER-================================================================--Template Haskell-~~~~~~~~~~~~~~~~-A module using template haskell may invoke an imported function from inside a-splice. This will cause the type-checker to attempt to execute that code, which-would fail if no object files had been generated. See #8025. To rectify this,-during the downsweep we patch the DynFlags in the ModSummary of any home module-that is imported by a module that uses template haskell, to generate object-code.--The flavour of generated object code is chosen by defaultObjectTarget for the-target platform. It would likely be faster to generate bytecode, but this is not-supported on all platforms(?Please Confirm?), and does not support the entirety-of GHC haskell. See #1257.--The object files (and interface files if -fwrite-interface is disabled) produced-for template haskell are written to temporary files.--Note that since template haskell can run arbitrary IO actions, -fno-code mode-is no more secure than running without it.--Potential TODOS:-~~~~~-* Remove -fwrite-interface and have interface files always written in -fno-code- mode-* Both .o and .dyn_o files are generated for template haskell, but we only need- .dyn_o. Fix it.-* In make mode, a message like- Compiling A (A.hs, /tmp/ghc_123.o)- is shown if downsweep enabled object code generation for A. Perhaps we should- show "nothing" or "temporary object file" instead. Note that one- can currently use -keep-tmp-files and inspect the generated file with the- current behaviour.-* Offer a -no-codedir command line option, and write what were temporary- object files there. This would speed up recompilation.-* Use existing object files (if they are up to date) instead of always- generating temporary ones.--}---- Note [When source is considered modified]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- A number of functions in GHC.Driver accept a SourceModified argument, which--- is part of how GHC determines whether recompilation may be avoided (see the--- definition of the SourceModified data type for details).------ Determining whether or not a source file is considered modified depends not--- only on the source file itself, but also on the output files which compiling--- that module would produce. This is done because GHC supports a number of--- flags which control which output files should be produced, e.g. -fno-code--- -fwrite-interface and -fwrite-ide-file; we must check not only whether the--- source file has been modified since the last compile, but also whether the--- source file has been modified since the last compile which produced all of--- the output files which have been requested.------ Specifically, a source file is considered unmodified if it is up-to-date--- relative to all of the output files which have been requested. Whether or--- not an output file is up-to-date depends on what kind of file it is:------ * iface (.hi) files are considered up-to-date if (and only if) their--- mi_src_hash field matches the hash of the source file,------ * all other output files (.o, .dyn_o, .hie, etc) are considered up-to-date--- if (and only if) their modification times on the filesystem are greater--- than or equal to the modification time of the corresponding .hi file.------ Why do we use '>=' rather than '>' for output files other than the .hi file?--- If the filesystem has poor resolution for timestamps (e.g. FAT32 has a--- resolution of 2 seconds), we may often find that the .hi and .o files have--- the same modification time. Using >= is slightly unsafe, but it matches--- make's behaviour.------ This strategy allows us to do the minimum work necessary in order to ensure--- that all the files the user cares about are up-to-date; e.g. we should not--- worry about .o files if the user has indicated that they are not interested--- in them via -fno-code. See also #9243.------ Note that recompilation avoidance is dependent on .hi files being produced,--- which does not happen if -fno-write-interface -fno-code is passed. That is,--- passing -fno-write-interface -fno-code means that you cannot benefit from--- recompilation avoidance. See also Note [-fno-code mode].------ The correctness of this strategy depends on an assumption that whenever we--- are producing multiple output files, the .hi file is always written first.--- If this assumption is violated, we risk recompiling unnecessarily by--- incorrectly regarding non-.hi files as outdated.------- --------------------------------------------------------------------------------- | Topological sort of the module graph-topSortModuleGraph- :: Bool- -- ^ Drop hi-boot nodes? (see below)- -> ModuleGraph- -> Maybe ModuleName- -- ^ Root module name. If @Nothing@, use the full graph.- -> [SCC ModuleGraphNode]--- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes--- The resulting list of strongly-connected-components is in topologically--- sorted order, starting with the module(s) at the bottom of the--- dependency graph (ie compile them first) and ending with the ones at--- the top.------ Drop hi-boot nodes (first boolean arg)?------ - @False@: treat the hi-boot summaries as nodes of the graph,--- so the graph must be acyclic------ - @True@: eliminate the hi-boot nodes, and instead pretend--- the a source-import of Foo is an import of Foo--- The resulting graph has no hi-boot nodes, but can be cyclic-topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod =- -- stronglyConnCompG flips the original order, so if we reverse- -- the summaries we get a stable topological sort.- topSortModules drop_hs_boot_nodes (reverse $ mgModSummaries' module_graph) mb_root_mod--topSortModules :: Bool -> [ModuleGraphNode] -> Maybe ModuleName -> [SCC ModuleGraphNode]-topSortModules drop_hs_boot_nodes summaries mb_root_mod- = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph- where- (graph, lookup_node) =- moduleGraphNodes drop_hs_boot_nodes summaries-- initial_graph = case mb_root_mod of- Nothing -> graph- Just root_mod ->- -- restrict the graph to just those modules reachable from- -- the specified module. We do this by building a graph with- -- the full set of nodes, and determining the reachable set from- -- the specified node.- let root | Just node <- lookup_node $ NodeKey_Module $ GWIB root_mod NotBoot- , graph `hasVertexG` node- = node- | otherwise- = throwGhcException (ProgramError "module does not exist")- in graphFromEdgedVerticesUniq (seq root (reachableG graph root))---- The nodes of the graph are keyed by (mod, is boot?) pairs for the current--- modules, and indefinite unit IDs for dependencies which are instantiated with--- our holes.------ NB: hsig files show up as *normal* nodes (not boot!), since they don't--- participate in cycles (for now)--mkNodeMap :: [ExtendedModSummary] -> ModNodeMap ExtendedModSummary-mkNodeMap summaries = ModNodeMap $ Map.fromList- [ (ms_mnwib $ emsModSummary s, s) | s <- summaries]--newtype ModNodeMap a = ModNodeMap { unModNodeMap :: Map.Map ModNodeKey a }- deriving (Functor, Traversable, Foldable)--emptyModNodeMap :: ModNodeMap a-emptyModNodeMap = ModNodeMap Map.empty--modNodeMapInsert :: ModNodeKey -> a -> ModNodeMap a -> ModNodeMap a-modNodeMapInsert k v (ModNodeMap m) = ModNodeMap (Map.insert k v m)--modNodeMapElems :: ModNodeMap a -> [a]-modNodeMapElems (ModNodeMap m) = Map.elems m--modNodeMapLookup :: ModNodeKey -> ModNodeMap a -> Maybe a-modNodeMapLookup k (ModNodeMap m) = Map.lookup k m---- | Efficiently construct a map from a NodeKey to its list of transitive dependencies-mkDepsMap :: [ModuleGraphNode] -> (NodeKey -> [NodeKey])-mkDepsMap nodes =- -- Important that we force this before returning a lambda so we can share the module graph- -- for each node- let !(mg, lookup_node) = moduleGraphNodes False nodes- in \nk -> map (mkNodeKey . node_payload) $ outgoingG mg (expectJust "mkDepsMap" (lookup_node nk))---- | If there are {-# SOURCE #-} imports between strongly connected--- components in the topological sort, then those imports can--- definitely be replaced by ordinary non-SOURCE imports: if SOURCE--- were necessary, then the edge would be part of a cycle.-warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()-warnUnnecessarySourceImports sccs = do- diag_opts <- initDiagOpts <$> getDynFlags- when (diag_wopt Opt_WarnUnusedImports diag_opts) $ do- let check ms =- let mods_in_this_cycle = map ms_mod_name ms in- [ warn i | m <- ms, i <- ms_home_srcimps m,- unLoc i `notElem` mods_in_this_cycle ]-- warn :: Located ModuleName -> MsgEnvelope GhcMessage- warn (L loc mod) = GhcDriverMessage <$> mkPlainMsgEnvelope diag_opts- loc (DriverUnnecessarySourceImports mod)- logDiagnostics (mkMessages $ listToBag (concatMap (check . flattenSCC) sccs))-------------------------------------------------------------------------------------- | Downsweep (dependency analysis)------ Chase downwards from the specified root set, returning summaries--- for all home modules encountered. Only follow source-import--- links.------ We pass in the previous collection of summaries, which is used as a--- cache to avoid recalculating a module summary if the source is--- unchanged.------ The returned list of [ModSummary] nodes has one node for each home-package--- module, plus one for any hs-boot files. The imports of these nodes--- are all there, including the imports of non-home-package modules.-downsweep :: HscEnv- -> [ExtendedModSummary]- -- ^ Old summaries- -> [ModuleName] -- Ignore dependencies on these; treat- -- them as if they were package modules- -> Bool -- True <=> allow multiple targets to have- -- the same module name; this is- -- very useful for ghc -M- -> IO [Either DriverMessages ExtendedModSummary]- -- The non-error elements of the returned list all have distinct- -- (Modules, IsBoot) identifiers, unless the Bool is true in- -- which case there can be repeats-downsweep hsc_env old_summaries excl_mods allow_dup_roots- = do- rootSummaries <- mapM getRootSummary roots- let (errs, rootSummariesOk) = partitionEithers rootSummaries -- #17549- root_map = mkRootMap rootSummariesOk- checkDuplicates root_map- map0 <- loop (concatMap calcDeps rootSummariesOk) root_map- -- if we have been passed -fno-code, we enable code generation- -- for dependencies of modules that have -XTemplateHaskell,- -- otherwise those modules will fail to compile.- -- See Note [-fno-code mode] #8025- let default_backend = platformDefaultBackend (targetPlatform dflags)- let home_unit = hsc_home_unit hsc_env- let tmpfs = hsc_tmpfs hsc_env- map1 <- case backend dflags of- NoBackend -> enableCodeGenForTH logger tmpfs home_unit default_backend map0- _ -> return map0- if null errs- then pure $ concat $ modNodeMapElems map1- else pure $ map Left errs- where- -- TODO(@Ericson2314): Probably want to include backpack instantiations- -- in the map eventually for uniformity- calcDeps (ExtendedModSummary ms _bkp_deps) = msDeps ms-- dflags = hsc_dflags hsc_env- logger = hsc_logger hsc_env- roots = hsc_targets hsc_env-- old_summary_map :: ModNodeMap ExtendedModSummary- old_summary_map = mkNodeMap old_summaries-- getRootSummary :: Target -> IO (Either DriverMessages ExtendedModSummary)- getRootSummary Target { targetId = TargetFile file mb_phase- , targetContents = maybe_buf- }- = do exists <- liftIO $ doesFileExist file- if exists || isJust maybe_buf- then summariseFile hsc_env old_summaries file mb_phase- maybe_buf- else return $ Left $ singleMessage- $ mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound file)- getRootSummary Target { targetId = TargetModule modl- , targetContents = maybe_buf- }- = do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot- (L rootLoc modl)- maybe_buf excl_mods- case maybe_summary of- Nothing -> return $ Left $ moduleNotFoundErr modl- Just s -> return s-- rootLoc = mkGeneralSrcSpan (fsLit "<command line>")-- -- In a root module, the filename is allowed to diverge from the module- -- name, so we have to check that there aren't multiple root files- -- defining the same module (otherwise the duplicates will be silently- -- ignored, leading to confusing behaviour).- checkDuplicates- :: ModNodeMap- [Either DriverMessages- ExtendedModSummary]- -> IO ()- checkDuplicates root_map- | allow_dup_roots = return ()- | null dup_roots = return ()- | otherwise = liftIO $ multiRootsErr (emsModSummary <$> head dup_roots)- where- dup_roots :: [[ExtendedModSummary]] -- Each at least of length 2- dup_roots = filterOut isSingleton $ map rights $ modNodeMapElems root_map-- loop :: [GenWithIsBoot (Located ModuleName)]- -- Work list: process these modules- -> ModNodeMap [Either DriverMessages ExtendedModSummary]- -- Visited set; the range is a list because- -- the roots can have the same module names- -- if allow_dup_roots is True- -> IO (ModNodeMap [Either DriverMessages ExtendedModSummary])- -- The result is the completed NodeMap- loop [] done = return done- loop (s : ss) done- | Just summs <- modNodeMapLookup key done- = if isSingleton summs then- loop ss done- else- do { multiRootsErr (emsModSummary <$> rights summs)- ; return (ModNodeMap Map.empty)- }- | otherwise- = do mb_s <- summariseModule hsc_env old_summary_map- is_boot wanted_mod- Nothing excl_mods- case mb_s of- Nothing -> loop ss done- Just (Left e) -> loop ss (modNodeMapInsert key [Left e] done)- Just (Right s)-> do- new_map <-- loop (calcDeps s) (modNodeMapInsert key [Right s] done)- loop ss new_map- where- GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = s- wanted_mod = L loc mod- key = GWIB- { gwib_mod = unLoc wanted_mod- , gwib_isBoot = is_boot- }---- | Update the every ModSummary that is depended on--- by a module that needs template haskell. We enable codegen to--- the specified target, disable optimization and change the .hi--- and .o file locations to be temporary files.--- See Note [-fno-code mode]-enableCodeGenForTH- :: Logger- -> TmpFs- -> HomeUnit- -> Backend- -> ModNodeMap [Either DriverMessages ExtendedModSummary]- -> IO (ModNodeMap [Either DriverMessages ExtendedModSummary])-enableCodeGenForTH logger tmpfs home_unit =- enableCodeGenWhen logger tmpfs condition should_modify TFL_CurrentModule TFL_GhcSession- where- condition = isTemplateHaskellOrQQNonBoot- should_modify (ModSummary { ms_hspp_opts = dflags }) =- backend dflags == NoBackend &&- -- Don't enable codegen for TH on indefinite packages; we- -- can't compile anything anyway! See #16219.- isHomeUnitDefinite home_unit---- | Helper used to implement 'enableCodeGenForTH'.--- In particular, this enables--- unoptimized code generation for all modules that meet some--- condition (first parameter), or are dependencies of those--- modules. The second parameter is a condition to check before--- marking modules for code generation.-enableCodeGenWhen- :: Logger- -> TmpFs- -> (ModSummary -> Bool)- -> (ModSummary -> Bool)- -> TempFileLifetime- -> TempFileLifetime- -> Backend- -> ModNodeMap [Either DriverMessages ExtendedModSummary]- -> IO (ModNodeMap [Either DriverMessages ExtendedModSummary])-enableCodeGenWhen logger tmpfs condition should_modify staticLife dynLife bcknd nodemap =- traverse (traverse (traverse enable_code_gen)) nodemap- where- enable_code_gen :: ExtendedModSummary -> IO ExtendedModSummary- enable_code_gen (ExtendedModSummary ms bkp_deps)- | ModSummary- { ms_mod = ms_mod- , ms_location = ms_location- , ms_hsc_src = HsSrcFile- , ms_hspp_opts = dflags- } <- ms- , should_modify ms- , ms_mod `Set.member` needs_codegen_set- = do- let new_temp_file suf dynsuf = do- tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf- let dyn_tn = tn -<.> dynsuf- addFilesToClean tmpfs dynLife [dyn_tn]- return (tn, dyn_tn)- -- We don't want to create .o or .hi files unless we have been asked- -- to by the user. But we need them, so we patch their locations in- -- the ModSummary with temporary files.- --- ((hi_file, dyn_hi_file), (o_file, dyn_o_file)) <-- -- If ``-fwrite-interface` is specified, then the .o and .hi files- -- are written into `-odir` and `-hidir` respectively. #16670- if gopt Opt_WriteInterface dflags- then return ((ml_hi_file ms_location, ml_dyn_hi_file ms_location)- , (ml_obj_file ms_location, ml_dyn_obj_file ms_location))- else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags))- <*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags))- let ms' = ms- { ms_location =- ms_location { ml_hi_file = hi_file- , ml_obj_file = o_file- , ml_dyn_hi_file = dyn_hi_file- , ml_dyn_obj_file = dyn_o_file }- , ms_hspp_opts = updOptLevel 0 $ dflags {backend = bcknd}- }- pure (ExtendedModSummary ms' bkp_deps)- | otherwise = return (ExtendedModSummary ms bkp_deps)-- needs_codegen_set = transitive_deps_set- [ ms- | mss <- modNodeMapElems nodemap- , Right (ExtendedModSummary { emsModSummary = ms }) <- mss- , condition ms- ]-- -- find the set of all transitive dependencies of a list of modules.- transitive_deps_set :: [ModSummary] -> Set.Set Module- transitive_deps_set modSums = foldl' go Set.empty modSums- where- go marked_mods ms@ModSummary{ms_mod}- | ms_mod `Set.member` marked_mods = marked_mods- | otherwise =- let deps =- [ dep_ms- -- If a module imports a boot module, msDeps helpfully adds a- -- dependency to that non-boot module in it's result. This- -- means we don't have to think about boot modules here.- | dep <- msDeps ms- , NotBoot == gwib_isBoot dep- , dep_ms_0 <- toList $ modNodeMapLookup (unLoc <$> dep) nodemap- , dep_ms_1 <- toList $ dep_ms_0- , (ExtendedModSummary { emsModSummary = dep_ms }) <- toList $ dep_ms_1- ]- new_marked_mods = Set.insert ms_mod marked_mods- in foldl' go new_marked_mods deps--mkRootMap- :: [ExtendedModSummary]- -> ModNodeMap [Either DriverMessages ExtendedModSummary]-mkRootMap summaries = ModNodeMap $ Map.insertListWith- (flip (++))- [ (msKey $ emsModSummary s, [Right s]) | s <- summaries ]- Map.empty---- | Returns the dependencies of the ModSummary s.--- A wrinkle is that for a {-# SOURCE #-} import we return--- *both* the hs-boot file--- *and* the source file--- as "dependencies". That ensures that the list of all relevant--- modules always contains B.hs if it contains B.hs-boot.--- Remember, this pass isn't doing the topological sort. It's--- just gathering the list of all relevant ModSummaries-msDeps :: ModSummary -> [GenWithIsBoot (Located ModuleName)]-msDeps s = [ d- | m <- ms_home_srcimps s- , d <- [ GWIB { gwib_mod = m, gwib_isBoot = IsBoot }- , GWIB { gwib_mod = m, gwib_isBoot = NotBoot }- ]- ]- ++ [ GWIB { gwib_mod = m, gwib_isBoot = NotBoot }- | m <- ms_home_imps s- ]---------------------------------------------------------------------------------- Summarising modules---- We have two types of summarisation:------ * Summarise a file. This is used for the root module(s) passed to--- cmLoadModules. The file is read, and used to determine the root--- module name. The module name may differ from the filename.------ * Summarise a module. We are given a module name, and must provide--- a summary. The finder is used to locate the file in which the module--- resides.--summariseFile- :: HscEnv- -> [ExtendedModSummary] -- old summaries- -> FilePath -- source file name- -> Maybe Phase -- start phase- -> Maybe (StringBuffer,UTCTime)- -> IO (Either DriverMessages ExtendedModSummary)--summariseFile hsc_env old_summaries src_fn mb_phase maybe_buf- -- we can use a cached summary if one is available and the- -- source file hasn't changed, But we have to look up the summary- -- by source file, rather than module name as we do in summarise.- | Just old_summary <- findSummaryBySourceFile old_summaries src_fn- = do- let location = ms_location $ emsModSummary old_summary-- src_hash <- get_src_hash- -- The file exists; we checked in getRootSummary above.- -- If it gets removed subsequently, then this- -- getFileHash may fail, but that's the right- -- behaviour.-- -- return the cached summary if the source didn't change- checkSummaryHash- hsc_env (new_summary src_fn)- old_summary location src_hash-- | otherwise- = do src_hash <- get_src_hash- new_summary src_fn src_hash- where- -- src_fn does not necessarily exist on the filesystem, so we need to- -- check what kind of target we are dealing with- get_src_hash = case maybe_buf of- Just (buf,_) -> return $ fingerprintStringBuffer buf- Nothing -> liftIO $ getFileHash src_fn-- new_summary src_fn src_hash = runExceptT $ do- preimps@PreprocessedImports {..}- <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf-- let fopts = initFinderOpts (hsc_dflags hsc_env)-- -- Make a ModLocation for this file- let location = mkHomeModLocation fopts pi_mod_name src_fn-- -- Tell the Finder cache where it is, so that subsequent calls- -- to findModule will find it, even if it's not on any search path- mod <- liftIO $ do- let home_unit = hsc_home_unit hsc_env- let fc = hsc_FC hsc_env- addHomeModuleToFinder fc home_unit pi_mod_name location-- liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary- { nms_src_fn = src_fn- , nms_src_hash = src_hash- , nms_is_boot = NotBoot- , nms_hsc_src =- if isHaskellSigFilename src_fn- then HsigFile- else HsSrcFile- , nms_location = location- , nms_mod = mod- , nms_preimps = preimps- }--findSummaryBySourceFile :: [ExtendedModSummary] -> FilePath -> Maybe ExtendedModSummary-findSummaryBySourceFile summaries file = case- [ ms- | ms <- summaries- , HsSrcFile <- [ms_hsc_src $ emsModSummary ms]- , let derived_file = ml_hs_file $ ms_location $ emsModSummary ms- , expectJust "findSummaryBySourceFile" derived_file == file- ]- of- [] -> Nothing- (x:_) -> Just x--checkSummaryHash- :: HscEnv- -> (Fingerprint -> IO (Either e ExtendedModSummary))- -> ExtendedModSummary -> ModLocation -> Fingerprint- -> IO (Either e ExtendedModSummary)-checkSummaryHash- hsc_env new_summary- (ExtendedModSummary { emsModSummary = old_summary, emsInstantiatedUnits = bkp_deps})- location src_hash- | ms_hs_hash old_summary == src_hash &&- not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do- -- update the object-file timestamp- obj_timestamp <- modificationTimeIfExists (ml_obj_file location)-- -- We have to repopulate the Finder's cache for file targets- -- because the file might not even be on the regular search path- -- and it was likely flushed in depanal. This is not technically- -- needed when we're called from sumariseModule but it shouldn't- -- hurt.- _ <- do- let home_unit = hsc_home_unit hsc_env- let fc = hsc_FC hsc_env- addHomeModuleToFinder fc home_unit- (moduleName (ms_mod old_summary)) location-- hi_timestamp <- modificationTimeIfExists (ml_hi_file location)- hie_timestamp <- modificationTimeIfExists (ml_hie_file location)-- return $ Right- ( ExtendedModSummary { emsModSummary = old_summary- { ms_obj_date = obj_timestamp- , ms_iface_date = hi_timestamp- , ms_hie_date = hie_timestamp- }- , emsInstantiatedUnits = bkp_deps- }- )-- | otherwise =- -- source changed: re-summarise.- new_summary src_hash---- Summarise a module, and pick up source and timestamp.-summariseModule- :: HscEnv- -> ModNodeMap ExtendedModSummary- -- ^ Map of old summaries- -> IsBootInterface -- True <=> a {-# SOURCE #-} import- -> Located ModuleName -- Imported module to be summarised- -> Maybe (StringBuffer, UTCTime)- -> [ModuleName] -- Modules to exclude- -> IO (Maybe (Either DriverMessages ExtendedModSummary)) -- Its new summary--summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)- maybe_buf excl_mods- | wanted_mod `elem` excl_mods- = return Nothing-- | Just old_summary <- modNodeMapLookup- (GWIB { gwib_mod = wanted_mod, gwib_isBoot = is_boot })- old_summary_map- = do -- Find its new timestamp; all the- -- ModSummaries in the old map have valid ml_hs_files- let location = ms_location $ emsModSummary old_summary- src_fn = expectJust "summariseModule" (ml_hs_file location)-- -- check the hash on the source file, and- -- return the cached summary if it hasn't changed. If the- -- file has disappeared, we need to call the Finder again.- case maybe_buf of- Just (buf,_) ->- Just <$> check_hash old_summary location src_fn (fingerprintStringBuffer buf)- Nothing -> do- mb_hash <- fileHashIfExists src_fn- case mb_hash of- Just hash -> Just <$> check_hash old_summary location src_fn hash- Nothing -> find_it-- | otherwise = find_it- where- dflags = hsc_dflags hsc_env- fopts = initFinderOpts dflags- mhome_unit = ue_home_unit (hsc_unit_env hsc_env)- fc = hsc_FC hsc_env- units = hsc_units hsc_env-- check_hash old_summary location src_fn =- checkSummaryHash- hsc_env- (new_summary location (ms_mod $ emsModSummary old_summary) src_fn)- old_summary location-- find_it = do- found <- findImportedModule fc fopts units mhome_unit wanted_mod NoPkgQual- case found of- Found location mod- | isJust (ml_hs_file location) ->- -- Home package- Just <$> just_found location mod-- _ -> return Nothing- -- Not found- -- (If it is TRULY not found at all, we'll- -- error when we actually try to compile)-- just_found location mod = do- -- Adjust location to point to the hs-boot source file,- -- hi file, object file, when is_boot says so- let location' = case is_boot of- IsBoot -> addBootSuffixLocn location- NotBoot -> location- src_fn = expectJust "summarise2" (ml_hs_file location')-- -- Check that it exists- -- It might have been deleted since the Finder last found it- maybe_h <- fileHashIfExists src_fn- case maybe_h of- Nothing -> return $ Left $ noHsFileErr loc src_fn- Just h -> new_summary location' mod src_fn h-- new_summary location mod src_fn src_hash- = runExceptT $ do- preimps@PreprocessedImports {..}- <- getPreprocessedImports hsc_env src_fn Nothing maybe_buf-- -- NB: Despite the fact that is_boot is a top-level parameter, we- -- don't actually know coming into this function what the HscSource- -- of the module in question is. This is because we may be processing- -- this module because another module in the graph imported it: in this- -- case, we know if it's a boot or not because of the {-# SOURCE #-}- -- annotation, but we don't know if it's a signature or a regular- -- module until we actually look it up on the filesystem.- let hsc_src- | is_boot == IsBoot = HsBootFile- | isHaskellSigFilename src_fn = HsigFile- | otherwise = HsSrcFile-- when (pi_mod_name /= wanted_mod) $- throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc- $ DriverFileModuleNameMismatch pi_mod_name wanted_mod-- let instantiations = fromMaybe [] (homeUnitInstantiations <$> mhome_unit)- when (hsc_src == HsigFile && isNothing (lookup pi_mod_name instantiations)) $- throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc- $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations-- liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary- { nms_src_fn = src_fn- , nms_src_hash = src_hash- , nms_is_boot = is_boot- , nms_hsc_src = hsc_src- , nms_location = location- , nms_mod = mod- , nms_preimps = preimps- }---- | Convenience named arguments for 'makeNewModSummary' only used to make--- code more readable, not exported.-data MakeNewModSummary- = MakeNewModSummary- { nms_src_fn :: FilePath- , nms_src_hash :: Fingerprint- , nms_is_boot :: IsBootInterface- , nms_hsc_src :: HscSource- , nms_location :: ModLocation- , nms_mod :: Module- , nms_preimps :: PreprocessedImports- }--makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ExtendedModSummary-makeNewModSummary hsc_env MakeNewModSummary{..} = do- let PreprocessedImports{..} = nms_preimps- obj_timestamp <- modificationTimeIfExists (ml_obj_file nms_location)- dyn_obj_timestamp <- modificationTimeIfExists (ml_dyn_obj_file nms_location)- hi_timestamp <- modificationTimeIfExists (ml_hi_file nms_location)- hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location)-- extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name- (implicit_sigs, inst_deps) <- implicitRequirementsShallow hsc_env pi_theimps-- return $ ExtendedModSummary- { emsModSummary =- ModSummary- { ms_mod = nms_mod- , ms_hsc_src = nms_hsc_src- , ms_location = nms_location- , ms_hspp_file = pi_hspp_fn- , ms_hspp_opts = pi_local_dflags- , ms_hspp_buf = Just pi_hspp_buf- , ms_parsed_mod = Nothing- , ms_srcimps = pi_srcimps- , ms_ghc_prim_import = pi_ghc_prim_import- , ms_textual_imps =- ((,) NoPkgQual . noLoc <$> extra_sig_imports) ++- ((,) NoPkgQual . noLoc <$> implicit_sigs) ++- pi_theimps- , ms_hs_hash = nms_src_hash- , ms_iface_date = hi_timestamp- , ms_hie_date = hie_timestamp- , ms_obj_date = obj_timestamp- , ms_dyn_obj_date = dyn_obj_timestamp- }- , emsInstantiatedUnits = inst_deps- }--data PreprocessedImports- = PreprocessedImports- { pi_local_dflags :: DynFlags- , pi_srcimps :: [(PkgQual, Located ModuleName)]- , pi_theimps :: [(PkgQual, Located ModuleName)]- , pi_ghc_prim_import :: Bool- , pi_hspp_fn :: FilePath- , pi_hspp_buf :: StringBuffer- , pi_mod_name_loc :: SrcSpan- , pi_mod_name :: ModuleName- }---- Preprocess the source file and get its imports--- The pi_local_dflags contains the OPTIONS pragmas-getPreprocessedImports- :: HscEnv- -> FilePath- -> Maybe Phase- -> Maybe (StringBuffer, UTCTime)- -- ^ optional source code buffer and modification time- -> ExceptT DriverMessages IO PreprocessedImports-getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do- (pi_local_dflags, pi_hspp_fn)- <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase- pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn- (pi_srcimps', pi_theimps', pi_ghc_prim_import, L pi_mod_name_loc pi_mod_name)- <- ExceptT $ do- let imp_prelude = xopt LangExt.ImplicitPrelude pi_local_dflags- popts = initParserOpts pi_local_dflags- mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn- return (first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps)- let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)- let rn_imps = fmap (first rn_pkg_qual)- let pi_srcimps = rn_imps pi_srcimps'- let pi_theimps = rn_imps pi_theimps'- return PreprocessedImports {..}----------------------------------------------------------------------------------- Error messages---------------------------------------------------------------------------------- Defer and group warning, error and fatal messages so they will not get lost--- in the regular output.-withDeferredDiagnostics :: GhcMonad m => m a -> m a-withDeferredDiagnostics f = do- dflags <- getDynFlags- if not $ gopt Opt_DeferDiagnostics dflags- then f- else do- warnings <- liftIO $ newIORef []- errors <- liftIO $ newIORef []- fatals <- liftIO $ newIORef []- logger <- getLogger-- let deferDiagnostics _dflags !msgClass !srcSpan !msg = do- let action = logMsg logger msgClass srcSpan msg- case msgClass of- MCDiagnostic SevWarning _reason- -> atomicModifyIORef' warnings $ \i -> (action: i, ())- MCDiagnostic SevError _reason- -> atomicModifyIORef' errors $ \i -> (action: i, ())- MCFatal- -> atomicModifyIORef' fatals $ \i -> (action: i, ())- _ -> action-- printDeferredDiagnostics = liftIO $- forM_ [warnings, errors, fatals] $ \ref -> do- -- This IORef can leak when the dflags leaks, so let us always- -- reset the content.- actions <- atomicModifyIORef' ref $ \i -> ([], i)- sequence_ $ reverse actions-- MC.bracket- (pushLogHookM (const deferDiagnostics))- (\_ -> popLogHookM >> printDeferredDiagnostics)- (\_ -> f)--noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope GhcMessage--- ToDo: we don't have a proper line number for this error-noModError hsc_env loc wanted_mod err- = mkPlainErrorMsgEnvelope loc $ GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $- cannotFindModule hsc_env wanted_mod err--noHsFileErr :: SrcSpan -> String -> DriverMessages-noHsFileErr loc path- = singleMessage $ mkPlainErrorMsgEnvelope loc (DriverFileNotFound path)--moduleNotFoundErr :: ModuleName -> DriverMessages-moduleNotFoundErr mod- = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverModuleNotFound mod)--multiRootsErr :: [ModSummary] -> IO ()-multiRootsErr [] = panic "multiRootsErr"-multiRootsErr summs@(summ1:_)- = throwOneError $ fmap GhcDriverMessage $- mkPlainErrorMsgEnvelope noSrcSpan $ DriverDuplicatedModuleDeclaration mod files- where- mod = ms_mod summ1- files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs--cyclicModuleErr :: [ModuleGraphNode] -> SDoc--- From a strongly connected component we find--- a single cycle to report-cyclicModuleErr mss- = assert (not (null mss)) $- case findCycle graph of- Nothing -> text "Unexpected non-cycle" <+> ppr mss- Just path0 -> vcat- [ case partitionNodes path0 of- ([],_) -> text "Module imports form a cycle:"- (_,[]) -> text "Module instantiations form a cycle:"- _ -> text "Module imports and instantiations form a cycle:"- , nest 2 (show_path path0)]- where- graph :: [Node NodeKey ModuleGraphNode]- graph =- [ DigraphNode- { node_payload = ms- , node_key = mkNodeKey ms- , node_dependencies = get_deps ms- }- | ms <- mss- ]-- get_deps :: ModuleGraphNode -> [NodeKey]- get_deps = \case- InstantiationNode iuid ->- [ NodeKey_Module $ GWIB { gwib_mod = hole, gwib_isBoot = NotBoot }- | hole <- uniqDSetToList $ instUnitHoles iuid- ]- ModuleNode (ExtendedModSummary ms bds) ->- [ NodeKey_Module $ GWIB { gwib_mod = unLoc m, gwib_isBoot = IsBoot }- | m <- ms_home_srcimps ms ] ++- [ NodeKey_Unit inst_unit- | inst_unit <- bds ] ++- [ NodeKey_Module $ GWIB { gwib_mod = unLoc m, gwib_isBoot = NotBoot }- | m <- ms_home_imps ms ]-- show_path :: [ModuleGraphNode] -> SDoc- show_path [] = panic "show_path"- show_path [m] = ppr_node m <+> text "imports itself"- show_path (m1:m2:ms) = vcat ( nest 6 (ppr_node m1)- : nest 6 (text "imports" <+> ppr_node m2)- : go ms )- where- go [] = [text "which imports" <+> ppr_node m1]- go (m:ms) = (text "which imports" <+> ppr_node m) : go ms-- ppr_node :: ModuleGraphNode -> SDoc- ppr_node (ModuleNode m) = text "module" <+> ppr_ms (emsModSummary m)- ppr_node (InstantiationNode u) = text "instantiated unit" <+> ppr u-- ppr_ms :: ModSummary -> SDoc- ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+>- (parens (text (msHsFilePath ms)))---cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m ()-cleanCurrentModuleTempFilesMaybe logger tmpfs dflags =- unless (gopt Opt_KeepTmpFiles dflags) $- liftIO $ cleanCurrentModuleTempFiles logger tmpfs---addDepsToHscEnv :: [HomeModInfo] -> HscEnv -> HscEnv-addDepsToHscEnv deps hsc_env =- hscUpdateHPT (const $ listHMIToHpt deps) hsc_env--setHPT :: HomePackageTable -> HscEnv -> HscEnv-setHPT deps hsc_env =- hscUpdateHPT (const $ deps) hsc_env---- | Wrap an action to catch and handle exceptions.-wrapAction :: HscEnv -> IO a -> IO (Maybe a)-wrapAction hsc_env k = do- let lcl_logger = hsc_logger hsc_env- lcl_dynflags = hsc_dflags hsc_env- let logg err = printMessages lcl_logger (initDiagOpts lcl_dynflags) (srcErrorMessages err)- -- MP: It is a bit strange how prettyPrintGhcErrors handles some errors but then we handle- -- SourceError and ThreadKilled differently directly below. TODO: Refactor to use `catches`- -- directly. MP should probably use safeTry here to not catch async exceptions but that will regress performance due to- -- internally using forkIO.- mres <- MC.try $ liftIO $ prettyPrintGhcErrors lcl_logger $ k- case mres of- Right res -> return $ Just res- Left exc -> do- case fromException exc of- Just (err :: SourceError)- -> logg err- Nothing -> case fromException exc of- -- ThreadKilled in particular needs to actually kill the thread.- -- So rethrow that and the other async exceptions- Just (err :: SomeAsyncException) -> throwIO err- _ -> errorMsg lcl_logger (text (show exc))- return Nothing--withParLog :: TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> RunMakeM b) -> RunMakeM b-withParLog lqq_var k cont = do- let init_log = liftIO $ do- -- Make a new log queue- lq <- newLogQueue k- -- Add it into the LogQueueQueue- atomically $ initLogQueue lqq_var lq- return lq- finish_log lq = liftIO (finishLogQueue lq)- MC.bracket init_log finish_log $ \lq -> cont (pushLogHook (const (parLogAction lq)))--withLoggerHsc :: Int -> (HscEnv -> RunMakeM a) -> RunMakeM a-withLoggerHsc k cont = do- MakeEnv{withLogger, hsc_env} <- ask- withLogger k $ \modifyLogger -> do- let lcl_logger = modifyLogger (hsc_logger hsc_env)- hsc_env' = hsc_env { hsc_logger = lcl_logger }- -- Run continuation with modified logger- cont hsc_env'---- Executing compilation graph nodes--executeInstantiationNode :: Int- -> Int- -> RunMakeM HomePackageTable- -> InstantiatedUnit- -> RunMakeM ()-executeInstantiationNode k n wait_deps iu = do- withLoggerHsc k $ \hsc_env -> do- -- Wait for the dependencies of this node- deps <- wait_deps- -- Output of the logger is mediated by a central worker to- -- avoid output interleaving- let lcl_hsc_env = setHPT deps hsc_env- msg <- asks env_messager- lift $ MaybeT $ wrapAction lcl_hsc_env $ do- res <- upsweep_inst lcl_hsc_env msg k n iu- cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env)- return res---executeCompileNode :: Int- -> Int- -> Maybe HomeModInfo- -> RunMakeM HomePackageTable- -> Maybe [ModuleName] -- List of modules we need to rehydrate before compiling- -> ModSummary- -> RunMakeM HomeModInfo-executeCompileNode k n !old_hmi wait_deps mrehydrate_mods mod = do- MakeEnv{..} <- ask- deps <- wait_deps- -- Rehydrate any dependencies if this module had a boot file or is a signature file.- withLoggerHsc k $ \hsc_env -> do- hydrated_hsc_env <- liftIO $ maybeRehydrateBefore (setHPT deps hsc_env) mod fixed_mrehydrate_mods- let -- Use the cached DynFlags which includes OPTIONS_GHC pragmas- lcl_dynflags = ms_hspp_opts mod- let lcl_hsc_env =- -- Localise the hsc_env to use the cached flags- hscSetFlags lcl_dynflags $- hydrated_hsc_env- -- Compile the module, locking with a semphore to avoid too many modules- -- being compiled at the same time leading to high memory usage.- lift $ MaybeT (withAbstractSem compile_sem $ wrapAction lcl_hsc_env $ do- res <- upsweep_mod lcl_hsc_env env_messager old_hmi mod k n- cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) lcl_dynflags- return res)-- where- fixed_mrehydrate_mods =- case ms_hsc_src mod of- -- MP: It is probably a bit of a misimplementation in backpack that- -- compiling a signature requires an knot_var for that unit.- -- If you remove this then a lot of backpack tests fail.- HsigFile -> Just []- _ -> mrehydrate_mods--{- Rehydration, see Note [Rehydrating Modules] -}--rehydrate :: HscEnv -- ^ The HPT in this HscEnv needs rehydrating.- -> [HomeModInfo] -- ^ These are the modules we want to rehydrate.- -> IO HscEnv-rehydrate hsc_env hmis = do- debugTraceMsg logger 2 $- text "Re-hydrating loop: "- new_mods <- fixIO $ \new_mods -> do- let new_hpt = addListToHpt old_hpt new_mods- let new_hsc_env = hscUpdateHPT (const new_hpt) hsc_env- mds <- initIfaceCheck (text "rehydrate") new_hsc_env $- mapM (typecheckIface . hm_iface) hmis- let new_mods = [ (mn,hmi{ hm_details = details })- | (hmi,details) <- zip hmis mds- , let mn = moduleName (mi_module (hm_iface hmi)) ]- return new_mods- return $ setHPT (foldl' (\old (mn, hmi) -> addToHpt old mn hmi) old_hpt new_mods) hsc_env-- where- logger = hsc_logger hsc_env- to_delete = (map (moduleName . mi_module . hm_iface) hmis)- -- Filter out old modules before tying the knot, otherwise we can end- -- up with a thunk which keeps reference to the old HomeModInfo.- !old_hpt = foldl' delFromHpt (hsc_HPT hsc_env) to_delete---- If needed, then rehydrate the necessary modules with a suitable KnotVars for the--- module currently being compiled.-maybeRehydrateBefore :: HscEnv -> ModSummary -> Maybe [ModuleName] -> IO HscEnv-maybeRehydrateBefore hsc_env _ Nothing = return hsc_env-maybeRehydrateBefore hsc_env mod (Just mns) = do- knot_var <- initialise_knot_var hsc_env- let hmis = map (expectJust "mr" . lookupHpt (hsc_HPT hsc_env)) mns- rehydrate (hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv knot_var }) hmis-- where- initialise_knot_var hsc_env = liftIO $- let mod_name = homeModuleInstantiation (hsc_home_unit_maybe hsc_env) (ms_mod mod)- in mkModuleEnv . (:[]) . (mod_name,) <$> newIORef emptyTypeEnv--maybeRehydrateAfter :: HomeModInfo- -> HscEnv- -> Maybe [ModuleName]- -> IO (HomePackageTable, HomeModInfo)-maybeRehydrateAfter hmi new_hsc Nothing = return (hsc_HPT new_hsc, hmi)-maybeRehydrateAfter hmi new_hsc (Just mns) = do- let new_hpt = hsc_HPT new_hsc- hmis = map (expectJust "mrAfter" . lookupHpt new_hpt) mns- new_mod_name = moduleName (mi_module (hm_iface hmi))- final_hpt <- hsc_HPT <$> rehydrate (new_hsc { hsc_type_env_vars = emptyKnotVars }) (hmi : hmis)- return (final_hpt, expectJust "rehydrate" $ lookupHpt final_hpt new_mod_name)--{--Note [Hydrating Modules]-~~~~~~~~~~~~~~~~~~~~~~~~-There are at least 4 different representations of an interface file as described-by this diagram.---------------------------------| On-disk M.hi |-------------------------------- | ^- | Read file | Write file- V |---------------------------------| ByteString |--------------------------------- | ^- | Binary.get | Binary.put- V |----------------------------------| ModIface (an acyclic AST) |---------------------------------- | ^- | hydrate | mkIfaceTc- V |-----------------------------------| ModDetails (lots of cycles) |------------------------------------The last step, converting a ModIface into a ModDetails is known as "hydration".--Hydration happens in three different places--* When an interface file is initially loaded from disk, it has to be hydrated.-* When a module is finished compiling, we hydrate the ModIface in order to generate- the version of ModDetails which exists in memory (see Note [ModDetails and --make mode])-* When dealing with boot files and module loops (see Note [Rehydrating Modules])--Note [Rehydrating Modules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-If a module has a boot file then it is critical to rehydrate the modules on-the path between the two (see #20561).--Suppose we have ("R" for "recursive"):-```-R.hs-boot: module R where- data T- g :: T -> T--A.hs: module A( f, T, g ) where- import {-# SOURCE #-} R- data S = MkS T- f :: T -> S = ...g...--R.hs: module R where- import A- data T = T1 | T2 S- g = ...f...-```--## Why we need to rehydrate A's ModIface before compiling R.hs--After compiling A.hs we'll have a TypeEnv in which the Id for `f` has a type-type uses the AbstractTyCon T; and a TyCon for `S` that also mentions that same-AbstractTyCon. (Abstract because it came from R.hs-boot; we know nothing about-it.)--When compiling R.hs, we build a TyCon for `T`. But that TyCon mentions `S`, and-it currently has an AbstractTyCon for `T` inside it. But we want to build a-fully cyclic structure, in which `S` refers to `T` and `T` refers to `S`.--Solution: **rehydration**. *Before compiling `R.hs`*, rehydrate all the-ModIfaces below it that depend on R.hs-boot. To rehydrate a ModIface, call-`rehydrateIface` to convert it to a ModDetails. It's just a de-serialisation-step, no type inference, just lookups.--Now `S` will be bound to a thunk that, when forced, will "see" the final binding-for `T`; see [Tying the knot](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/tying-the-knot).-But note that this must be done *before* compiling R.hs.--## Why we need to rehydrate A's ModIface after compiling R.hs--When compiling R.hs, the knot-tying stuff above will ensure that `f`'s unfolding-mentions the `LocalId` for `g`. But when we finish R, we carefully ensure that-all those `LocalIds` are turned into completed `GlobalIds`, replete with-unfoldings etc. Alas, that will not apply to the occurrences of `g` in `f`'s-unfolding. And if we leave matters like that, they will stay that way, and *all*-subsequent modules that import A will see a crippled unfolding for `f`.--Solution: rehydrate both R and A's ModIface together, right after completing R.hs.--## Which modules to rehydrate--We only need rehydrate modules that are-* Below R.hs-* Above R.hs-boot--There might be many unrelated modules (in the home package) that don't need to be-rehydrated.--## Modules "above" the loop--This dark corner is the subject of #14092.--Suppose we add to our example-```-X.hs module X where- import A- data XT = MkX T- fx = ...g...-```-If in `--make` we compile R.hs-boot, then A.hs, then X.hs, we'll get a `ModDetails` for `X` that has an AbstractTyCon for `T` in the the argument type of `MkX`. So:--* Either we should delay compiling X until after R has beeen compiled. (This is what we do)-* Or we should rehydrate X after compiling R -- because it transitively depends on R.hs-boot.--Ticket #20200 has exposed some issues to do with the knot-tying logic in GHC.Make, in `--make` mode.-#20200 has lots of issues, many of them now fixed;-this particular issue starts [here](https://gitlab.haskell.org/ghc/ghc/-/issues/20200#note_385758).--The wiki page [Tying the knot](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/tying-the-knot) is helpful.-Also closely related are- * #14092- * #14103---}----- | Wait for some dependencies to finish and then read from the given MVar.-wait_deps_hpt :: MVar b -> [ResultVar (Maybe HomeModInfo)] -> ReaderT MakeEnv (MaybeT IO) b-wait_deps_hpt hpt_var deps = do- _ <- wait_deps deps- liftIO $ readMVar hpt_var----- | Wait for dependencies to finish, and then return their results.-wait_deps :: [ResultVar (Maybe HomeModInfo)] -> RunMakeM [HomeModInfo]-wait_deps [] = return []-wait_deps (x:xs) = do- res <- lift $ waitResult x- case res of- Nothing -> wait_deps xs- Just hmi -> (hmi:) <$> wait_deps xs----- Executing the pipelines---- | Start a thread which reads from the LogQueueQueue-logThread :: Logger -> TVar Bool -- Signal that no more new logs will be added, clear the queue and exit- -> TVar LogQueueQueue -- Queue for logs- -> IO (IO ())-logThread logger stopped lqq_var = do- finished_var <- newEmptyMVar- _ <- forkIO $ print_logs *> putMVar finished_var ()- return (takeMVar finished_var)- where- finish = mapM (printLogs logger)-- print_logs = join $ atomically $ do- lqq <- readTVar lqq_var- case dequeueLogQueueQueue lqq of- Just (lq, lqq') -> do- writeTVar lqq_var lqq'- return (printLogs logger lq *> print_logs)- Nothing -> do- -- No log to print, check if we are finished.- stopped <- readTVar stopped- if not stopped then retry- else return (finish (allLogQueues lqq))---label_self :: String -> IO ()-label_self thread_name = do- self_tid <- CC.myThreadId- CC.labelThread self_tid thread_name---runPipelines :: Int -> HscEnv -> Maybe Messager -> [MakeAction] -> IO ()-runPipelines n_job orig_hsc_env mHscMessager all_pipelines = do- liftIO $ label_self "main --make thread"-- plugins_hsc_env <- initializePlugins orig_hsc_env Nothing- case n_job of- 1 -> runSeqPipelines plugins_hsc_env mHscMessager all_pipelines- _n -> runParPipelines n_job plugins_hsc_env mHscMessager all_pipelines--runSeqPipelines :: HscEnv -> Maybe Messager -> [MakeAction] -> IO ()-runSeqPipelines plugin_hsc_env mHscMessager all_pipelines =- let env = MakeEnv { hsc_env = plugin_hsc_env- , withLogger = \_ k -> k id- , compile_sem = AbstractSem (return ()) (return ())- , env_messager = mHscMessager- }- in runAllPipelines 1 env all_pipelines----- | Build and run a pipeline-runParPipelines :: Int -- ^ How many capabilities to use- -> HscEnv -- ^ The basic HscEnv which is augmented with specific info for each module- -> Maybe Messager -- ^ Optional custom messager to use to report progress- -> [MakeAction] -- ^ The build plan for all the module nodes- -> IO ()-runParPipelines n_jobs plugin_hsc_env mHscMessager all_pipelines = do--- -- A variable which we write to when an error has happened and we have to tell the- -- logging thread to gracefully shut down.- stopped_var <- newTVarIO False- -- The queue of LogQueues which actions are able to write to. When an action starts it- -- will add it's LogQueue into this queue.- log_queue_queue_var <- newTVarIO newLogQueueQueue- -- Thread which coordinates the printing of logs- wait_log_thread <- logThread (hsc_logger plugin_hsc_env) stopped_var log_queue_queue_var+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE MultiWayIf #-}++-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow, 2011+--+-- This module implements multi-module compilation, and is used+-- by --make and GHCi.+--+-- -----------------------------------------------------------------------------+module GHC.Driver.Make (+ depanal, depanalE, depanalPartial, checkHomeUnitsClosed,+ load, loadWithCache, load', LoadHowMuch(..),+ instantiationNodes,++ downsweep,++ topSortModuleGraph,++ ms_home_srcimps, ms_home_imps,++ summariseModule,+ SummariseResult(..),+ summariseFile,+ hscSourceToIsBoot,+ findExtraSigImports,+ implicitRequirementsShallow,++ noModError, cyclicModuleErr,+ SummaryNode,+ IsBootInterface(..), mkNodeKey,++ ModNodeKey, ModNodeKeyWithUid(..),+ ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert, modNodeMapSingleton, modNodeMapUnionWith+ ) where++import GHC.Prelude+import GHC.Platform++import GHC.Tc.Utils.Backpack+import GHC.Tc.Utils.Monad ( initIfaceCheck )++import GHC.Runtime.Interpreter+import qualified GHC.Linker.Loader as Linker+import GHC.Linker.Types++import GHC.Runtime.Context++import GHC.Driver.Config.Finder (initFinderOpts)+import GHC.Driver.Config.Parser (initParserOpts)+import GHC.Driver.Config.Diagnostic+import GHC.Driver.Phases+import GHC.Driver.Pipeline+import GHC.Driver.Session+import GHC.Driver.Backend+import GHC.Driver.Monad+import GHC.Driver.Env+import GHC.Driver.Errors+import GHC.Driver.Errors.Types+import GHC.Driver.Main++import GHC.Parser.Header++import GHC.Iface.Load ( cannotFindModule )+import GHC.IfaceToCore ( typecheckIface )+import GHC.Iface.Recomp ( RecompileRequired ( MustCompile ) )++import GHC.Data.Bag ( listToBag )+import GHC.Data.Graph.Directed+import GHC.Data.FastString+import GHC.Data.Maybe ( expectJust )+import GHC.Data.StringBuffer+import qualified GHC.LanguageExtensions as LangExt++import GHC.Utils.Exception ( throwIO, SomeAsyncException )+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Misc+import GHC.Utils.Error+import GHC.Utils.Logger+import GHC.Utils.Fingerprint+import GHC.Utils.TmpFs++import GHC.Types.Basic+import GHC.Types.Error+import GHC.Types.Target+import GHC.Types.SourceFile+import GHC.Types.SourceError+import GHC.Types.SrcLoc+import GHC.Types.Unique.FM+import GHC.Types.Name+import GHC.Types.PkgQual++import GHC.Unit+import GHC.Unit.Env+import GHC.Unit.Finder+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.Graph+import GHC.Unit.Home.ModInfo++import Data.Either ( rights, partitionEithers, lefts )+import qualified Data.Map as Map+import qualified Data.Set as Set++import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask )+import qualified GHC.Conc as CC+import Control.Concurrent.MVar+import Control.Monad+import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )+import qualified Control.Monad.Catch as MC+import Data.IORef+import Data.Maybe+import Data.Time+import Data.Bifunctor (first)+import System.Directory+import System.FilePath+import System.IO ( fixIO )++import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )+import Control.Monad.IO.Class+import Control.Monad.Trans.Reader+import GHC.Driver.Pipeline.LogQueue+import qualified Data.Map.Strict as M+import GHC.Types.TypeEnv+import Control.Monad.Trans.State.Lazy+import Control.Monad.Trans.Class+import GHC.Driver.Env.KnotVars+import Control.Concurrent.STM+import Control.Monad.Trans.Maybe+import GHC.Runtime.Loader+import GHC.Rename.Names+++-- -----------------------------------------------------------------------------+-- Loading the program++-- | Perform a dependency analysis starting from the current targets+-- and update the session with the new module graph.+--+-- Dependency analysis entails parsing the @import@ directives and may+-- therefore require running certain preprocessors.+--+-- Note that each 'ModSummary' in the module graph caches its 'DynFlags'.+-- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the+-- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want+-- changes to the 'DynFlags' to take effect you need to call this function+-- again.+-- In case of errors, just throw them.+--+depanal :: GhcMonad m =>+ [ModuleName] -- ^ excluded modules+ -> Bool -- ^ allow duplicate roots+ -> m ModuleGraph+depanal excluded_mods allow_dup_roots = do+ (errs, mod_graph) <- depanalE excluded_mods allow_dup_roots+ if isEmptyMessages errs+ then pure mod_graph+ else throwErrors (fmap GhcDriverMessage errs)++-- | Perform dependency analysis like in 'depanal'.+-- In case of errors, the errors and an empty module graph are returned.+depanalE :: GhcMonad m => -- New for #17459+ [ModuleName] -- ^ excluded modules+ -> Bool -- ^ allow duplicate roots+ -> m (DriverMessages, ModuleGraph)+depanalE excluded_mods allow_dup_roots = do+ hsc_env <- getSession+ (errs, mod_graph) <- depanalPartial excluded_mods allow_dup_roots+ if isEmptyMessages errs+ then do+ hsc_env <- getSession+ let one_unit_messages get_mod_errs k hue = do+ errs <- get_mod_errs+ unknown_module_err <- warnUnknownModules (hscSetActiveUnitId k hsc_env) (homeUnitEnv_dflags hue) mod_graph++ let unused_home_mod_err = warnMissingHomeModules (homeUnitEnv_dflags hue) (hsc_targets hsc_env) mod_graph+ unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) (homeUnitEnv_dflags hue) mod_graph+++ return $ errs `unionMessages` unused_home_mod_err+ `unionMessages` unused_pkg_err+ `unionMessages` unknown_module_err++ all_errs <- liftIO $ unitEnv_foldWithKey one_unit_messages (return emptyMessages) (hsc_HUG hsc_env)+ logDiagnostics (GhcDriverMessage <$> all_errs)+ setSession hsc_env { hsc_mod_graph = mod_graph }+ pure (emptyMessages, mod_graph)+ else do+ -- We don't have a complete module dependency graph,+ -- The graph may be disconnected and is unusable.+ setSession hsc_env { hsc_mod_graph = emptyMG }+ pure (errs, emptyMG)+++-- | Perform dependency analysis like 'depanal' but return a partial module+-- graph even in the face of problems with some modules.+--+-- Modules which have parse errors in the module header, failing+-- preprocessors or other issues preventing them from being summarised will+-- simply be absent from the returned module graph.+--+-- Unlike 'depanal' this function will not update 'hsc_mod_graph' with the+-- new module graph.+depanalPartial+ :: GhcMonad m+ => [ModuleName] -- ^ excluded modules+ -> Bool -- ^ allow duplicate roots+ -> m (DriverMessages, ModuleGraph)+ -- ^ possibly empty 'Bag' of errors and a module graph.+depanalPartial excluded_mods allow_dup_roots = do+ hsc_env <- getSession+ let+ targets = hsc_targets hsc_env+ old_graph = hsc_mod_graph hsc_env+ logger = hsc_logger hsc_env++ withTiming logger (text "Chasing dependencies") (const ()) $ do+ liftIO $ debugTraceMsg logger 2 (hcat [+ text "Chasing modules from: ",+ hcat (punctuate comma (map pprTarget targets))])++ -- Home package modules may have been moved or deleted, and new+ -- source files may have appeared in the home package that shadow+ -- external package modules, so we have to discard the existing+ -- cached finder data.+ liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env)++ (errs, graph_nodes) <- liftIO $ downsweep+ hsc_env (mgModSummaries old_graph)+ excluded_mods allow_dup_roots+ let+ mod_graph = mkModuleGraph graph_nodes+ return (unionManyMessages errs, mod_graph)++-- | Collect the instantiations of dependencies to create 'InstantiationNode' work graph nodes.+-- These are used to represent the type checking that is done after+-- all the free holes (sigs in current package) relevant to that instantiation+-- are compiled. This is necessary to catch some instantiation errors.+--+-- In the future, perhaps more of the work of instantiation could be moved here,+-- instead of shoved in with the module compilation nodes. That could simplify+-- backpack, and maybe hs-boot too.+instantiationNodes :: UnitId -> UnitState -> [ModuleGraphNode]+instantiationNodes uid unit_state = InstantiationNode uid <$> iuids_to_check+ where+ iuids_to_check :: [InstantiatedUnit]+ iuids_to_check =+ nubSort $ concatMap goUnitId (explicitUnits unit_state)+ where+ goUnitId uid =+ [ recur+ | VirtUnit indef <- [uid]+ , inst <- instUnitInsts indef+ , recur <- (indef :) $ goUnitId $ moduleUnit $ snd inst+ ]++-- The linking plan for each module. If we need to do linking for a home unit+-- then this function returns a graph node which depends on all the modules in the home unit.++-- At the moment nothing can depend on these LinkNodes.+linkNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> Maybe (Either (Messages DriverMessage) ModuleGraphNode)+linkNodes summaries uid hue =+ let dflags = homeUnitEnv_dflags hue+ ofile = outputFile_ dflags++ unit_nodes :: [NodeKey]+ unit_nodes = map mkNodeKey (filter ((== uid) . moduleGraphNodeUnitId) summaries)+ -- Issue a warning for the confusing case where the user+ -- said '-o foo' but we're not going to do any linking.+ -- We attempt linking if either (a) one of the modules is+ -- called Main, or (b) the user said -no-hs-main, indicating+ -- that main() is going to come from somewhere else.+ --+ no_hs_main = gopt Opt_NoHsMain dflags++ main_sum = any (== NodeKey_Module (ModNodeKeyWithUid (GWIB (mainModuleNameIs dflags) NotBoot) uid)) unit_nodes++ do_linking = main_sum || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib++ in if | ghcLink dflags == LinkBinary && isJust ofile && not do_linking ->+ Just (Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverRedirectedNoMain $ mainModuleNameIs dflags))+ -- This should be an error, not a warning (#10895).+ | do_linking -> Just (Right (LinkNode unit_nodes uid))+ | otherwise -> Nothing++-- 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`.+--+-- Here "home module" means a module, that doesn't come from an other 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.+--+-- The warning in enabled by `-Wmissing-home-modules`. See #13129+warnMissingHomeModules :: DynFlags -> [Target] -> ModuleGraph -> DriverMessages+warnMissingHomeModules dflags targets mod_graph =+ if null missing+ then emptyMessages+ else warn+ 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.+ --+ -- For instance, `ghc --make src-exe/Main.hs` and+ -- `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)+ ->+ target_file == mod_file ||++ -- Don't warn on B.hs-boot if B.hs is specified (#16551)+ addBootSuffix target_file == mod_file ||++ -- 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++ missing = map (moduleName . ms_mod) $+ filter (not . is_known_module) $+ (filter (\ms -> ms_unitid ms == homeUnitId_ dflags)+ (mgModSummaries mod_graph))++ warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan+ $ DriverMissingHomeModules missing (checkBuildingCabalPackage dflags)++-- Check that any modules we want to reexport or hide are actually in the package.+warnUnknownModules :: HscEnv -> DynFlags -> ModuleGraph -> IO DriverMessages+warnUnknownModules hsc_env dflags mod_graph = do+ reexported_warns <- filterM check_reexport (Set.toList reexported_mods)+ return $ final_msgs hidden_warns reexported_warns+ where+ diag_opts = initDiagOpts dflags++ unit_mods = Set.fromList (map ms_mod_name+ (filter (\ms -> ms_unitid ms == homeUnitId_ dflags)+ (mgModSummaries mod_graph)))++ reexported_mods = reexportedModules dflags+ hidden_mods = hiddenModules dflags++ hidden_warns = hidden_mods `Set.difference` unit_mods++ lookupModule mn = findImportedModule hsc_env mn NoPkgQual++ check_reexport mn = do+ fr <- lookupModule mn+ case fr of+ Found _ m -> return (moduleUnitId m == homeUnitId_ dflags)+ _ -> return True+++ warn flag mod = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan+ $ flag mod++ final_msgs hidden_warns reexported_warns+ =+ unionManyMessages $+ [warn DriverUnknownHiddenModules (Set.toList hidden_warns) | not (Set.null hidden_warns)]+ ++ [warn DriverUnknownReexportedModules reexported_warns | not (null reexported_warns)]++-- | Describes which modules of the module graph need to be loaded.+data LoadHowMuch+ = LoadAllTargets+ -- ^ Load all targets and its dependencies.+ | LoadUpTo HomeUnitModule+ -- ^ Load only the given module and its dependencies.+ | LoadDependenciesOf HomeUnitModule+ -- ^ Load only the dependencies of the given module, but not the module+ -- itself.++-- | Try to load the program. See 'LoadHowMuch' for the different modes.+--+-- This function implements the core of GHC's @--make@ mode. It preprocesses,+-- compiles and loads the specified modules, avoiding re-compilation wherever+-- possible. Depending on the backend (see 'DynFlags.backend' field) compiling+-- and loading may result in files being created on disk.+--+-- Calls the 'defaultWarnErrLogger' after each compiling each module, whether+-- successful or not.+--+-- If errors are encountered during dependency analysis, the module `depanalE`+-- returns together with the errors an empty ModuleGraph.+-- After processing this empty ModuleGraph, the errors of depanalE are thrown.+-- All other errors are reported using the 'defaultWarnErrLogger'.++load :: GhcMonad f => LoadHowMuch -> f SuccessFlag+load how_much = fst <$> loadWithCache [] how_much++mkBatchMsg :: HscEnv -> Messager+mkBatchMsg hsc_env =+ if length (hsc_all_home_unit_ids hsc_env) > 1+ -- This also displays what unit each module is from.+ then batchMultiMsg+ else batchMsg++loadWithCache :: GhcMonad m => [HomeModInfo] -> LoadHowMuch -> m (SuccessFlag, [HomeModInfo])+loadWithCache cache how_much = do+ (errs, mod_graph) <- depanalE [] False -- #17459+ msg <- mkBatchMsg <$> getSession+ success <- load' cache how_much (Just msg) mod_graph+ if isEmptyMessages errs+ then pure success+ else throwErrors (fmap GhcDriverMessage errs)++-- Note [Unused packages]+--+-- Cabal passes `--package-id` flag for each direct dependency. But GHC+-- loads them lazily, so when compilation is done, we have a list of all+-- actually loaded packages. All the packages, specified on command line,+-- but never loaded, are probably unused dependencies.++warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages+warnUnusedPackages us dflags mod_graph =+ let diag_opts = initDiagOpts dflags++ -- Only need non-source imports here because SOURCE imports are always HPT+ loadedPackages = concat $+ mapMaybe (\(fs, mn) -> lookupModulePackage us (unLoc mn) fs)+ $ concatMap ms_imps (+ filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph))++ requestedArgs = mapMaybe packageArg (packageFlags dflags)++ unusedArgs+ = filter (\arg -> not $ any (matching us arg) loadedPackages)+ requestedArgs++ warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan (DriverUnusedPackages unusedArgs)++ in if null unusedArgs+ then emptyMessages+ else warn++ where+ packageArg (ExposePackage _ arg _) = Just arg+ packageArg _ = Nothing++ matchingStr :: String -> UnitInfo -> Bool+ matchingStr str p+ = str == unitPackageIdString p+ || str == unitPackageNameString p++ matching :: UnitState -> PackageArg -> UnitInfo -> Bool+ matching _ (PackageArg str) p = matchingStr str p+ matching state (UnitIdArg uid) p = uid == realUnit state p++ -- For wired-in packages, we have to unwire their id,+ -- otherwise they won't match package flags+ realUnit :: UnitState -> UnitInfo -> Unit+ realUnit state+ = unwireUnit state+ . RealUnit+ . Definite+ . unitId+++-- | A ModuleGraphNode which also has a hs-boot file, and the list of nodes on any+-- path from module to its boot file.+data ModuleGraphNodeWithBootFile+ = ModuleGraphNodeWithBootFile ModuleGraphNode [ModuleGraphNode]++instance Outputable ModuleGraphNodeWithBootFile where+ ppr (ModuleGraphNodeWithBootFile mgn deps) = text "ModeGraphNodeWithBootFile: " <+> ppr mgn $$ ppr deps++getNode :: ModuleGraphNodeWithBootFile -> ModuleGraphNode+getNode (ModuleGraphNodeWithBootFile mgn _) = mgn+data BuildPlan = SingleModule ModuleGraphNode -- A simple, single module all alone but *might* have an hs-boot file which isn't part of a cycle+ | ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile] -- A resolved cycle, linearised by hs-boot files+ | UnresolvedCycle [ModuleGraphNode] -- An actual cycle, which wasn't resolved by hs-boot files++instance Outputable BuildPlan where+ ppr (SingleModule mgn) = text "SingleModule" <> parens (ppr mgn)+ ppr (ResolvedCycle mgn) = text "ResolvedCycle:" <+> ppr mgn+ ppr (UnresolvedCycle mgn) = text "UnresolvedCycle:" <+> ppr mgn+++-- Just used for an assertion+countMods :: BuildPlan -> Int+countMods (SingleModule _) = 1+countMods (ResolvedCycle ns) = length ns+countMods (UnresolvedCycle ns) = length ns++-- See Note [Upsweep] for a high-level description.+createBuildPlan :: ModuleGraph -> Maybe HomeUnitModule -> [BuildPlan]+createBuildPlan mod_graph maybe_top_mod =+ let -- Step 1: Compute SCCs without .hi-boot files, to find the cycles+ cycle_mod_graph = topSortModuleGraph True mod_graph maybe_top_mod++ -- Step 2: Reanalyse loops, with relevant boot modules, to solve the cycles.+ build_plan :: [BuildPlan]+ build_plan+ -- Fast path, if there are no boot modules just do a normal toposort+ | isEmptyModuleEnv boot_modules = collapseAcyclic $ topSortModuleGraph False mod_graph maybe_top_mod+ | otherwise = toBuildPlan cycle_mod_graph []++ toBuildPlan :: [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan]+ toBuildPlan [] mgn = collapseAcyclic (topSortWithBoot mgn)+ toBuildPlan ((AcyclicSCC node):sccs) mgn = toBuildPlan sccs (node:mgn)+ -- Interesting case+ toBuildPlan ((CyclicSCC nodes):sccs) mgn =+ let acyclic = collapseAcyclic (topSortWithBoot mgn)+ -- Now perform another toposort but just with these nodes and relevant hs-boot files.+ -- The result should be acyclic, if it's not, then there's an unresolved cycle in the graph.+ mresolved_cycle = collapseSCC (topSortWithBoot nodes)+ in acyclic ++ [maybe (UnresolvedCycle nodes) ResolvedCycle mresolved_cycle] ++ toBuildPlan sccs []++ (mg, lookup_node) = moduleGraphNodes False (mgModSummaries' mod_graph)+ trans_deps_map = allReachable mg (mkNodeKey . node_payload)+ boot_path mn uid =+ map (summaryNodeSummary . expectJust "toNode" . lookup_node) $ Set.toList $+ Set.delete (NodeKey_Module (key IsBoot)) $+ expectJust "boot_path" (M.lookup (NodeKey_Module (key NotBoot)) trans_deps_map)+ `Set.difference` (expectJust "boot_path" (M.lookup (NodeKey_Module (key IsBoot)) trans_deps_map))+ where+ key ib = ModNodeKeyWithUid (GWIB mn ib) uid+++ -- An environment mapping a module to its hs-boot file and all nodes on the path between the two, if one exists+ boot_modules = mkModuleEnv+ [ (ms_mod ms, (m, boot_path (ms_mod_name ms) (ms_unitid ms))) | m@(ModuleNode _ ms) <- (mgModSummaries' mod_graph), isBootSummary ms == IsBoot]++ select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode]+ select_boot_modules = mapMaybe (fmap fst . get_boot_module)++ get_boot_module :: (ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode]))+ get_boot_module m = case m of ModuleNode _ ms | HsSrcFile <- ms_hsc_src ms -> lookupModuleEnv boot_modules (ms_mod ms); _ -> Nothing++ -- Any cycles should be resolved now+ collapseSCC :: [SCC ModuleGraphNode] -> Maybe [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)]+ -- Must be at least two nodes, as we were in a cycle+ collapseSCC [AcyclicSCC node1, AcyclicSCC node2] = Just [toNodeWithBoot node1, toNodeWithBoot node2]+ collapseSCC (AcyclicSCC node : nodes) = (toNodeWithBoot node :) <$> collapseSCC nodes+ -- Cyclic+ collapseSCC _ = Nothing++ toNodeWithBoot :: (ModuleGraphNode -> Either ModuleGraphNode ModuleGraphNodeWithBootFile)+ toNodeWithBoot mn =+ case get_boot_module mn of+ -- The node doesn't have a boot file+ Nothing -> Left mn+ -- The node does have a boot file+ Just path -> Right (ModuleGraphNodeWithBootFile mn (snd path))++ -- The toposort and accumulation of acyclic modules is solely to pick-up+ -- hs-boot files which are **not** part of cycles.+ collapseAcyclic :: [SCC ModuleGraphNode] -> [BuildPlan]+ collapseAcyclic (AcyclicSCC node : nodes) = SingleModule node : collapseAcyclic nodes+ collapseAcyclic (CyclicSCC cy_nodes : nodes) = (UnresolvedCycle cy_nodes) : collapseAcyclic nodes+ collapseAcyclic [] = []++ topSortWithBoot nodes = topSortModules False (select_boot_modules nodes ++ nodes) Nothing+++ in++ assertPpr (sum (map countMods build_plan) == length (mgModSummaries' mod_graph))+ (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr (length (mgModSummaries' mod_graph )))])+ build_plan++-- | Generalized version of 'load' which also supports a custom+-- 'Messager' (for reporting progress) and 'ModuleGraph' (generally+-- produced by calling 'depanal'.+load' :: GhcMonad m => [HomeModInfo] -> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m (SuccessFlag, [HomeModInfo])+load' cache how_much mHscMessage mod_graph = do+ modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph }+ guessOutputFile+ hsc_env <- getSession++ let dflags = hsc_dflags hsc_env+ let logger = hsc_logger hsc_env+ let interp = hscInterp hsc_env++ -- The "bad" boot modules are the ones for which we have+ -- B.hs-boot in the module graph, but no B.hs+ -- The downsweep should have ensured this does not happen+ -- (see msDeps)+ let all_home_mods =+ Set.fromList [ Module (ms_unitid s) (ms_mod_name s)+ | s <- mgModSummaries mod_graph, isBootSummary s == NotBoot]+ -- TODO: Figure out what the correct form of this assert is. It's violated+ -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot+ -- files without corresponding hs files.+ -- bad_boot_mods = [s | s <- mod_graph, isBootSummary s,+ -- not (ms_mod_name s `elem` all_home_mods)]+ -- assert (null bad_boot_mods ) return ()++ -- check that the module given in HowMuch actually exists, otherwise+ -- topSortModuleGraph will bomb later.+ let checkHowMuch (LoadUpTo m) = checkMod m+ checkHowMuch (LoadDependenciesOf m) = checkMod m+ checkHowMuch _ = id++ checkMod m and_then+ | m `Set.member` all_home_mods = and_then+ | otherwise = do+ liftIO $ errorMsg logger+ (text "no such module:" <+> quotes (ppr (moduleUnit m) <> colon <> ppr (moduleName m)))+ return (Failed, [])++ checkHowMuch how_much $ do++ -- mg2_with_srcimps drops the hi-boot nodes, returning a+ -- graph with cycles. It is just used for warning about unecessary source imports.+ let mg2_with_srcimps :: [SCC ModuleGraphNode]+ mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing++ -- If we can determine that any of the {-# SOURCE #-} imports+ -- are definitely unnecessary, then emit a warning.+ warnUnnecessarySourceImports (filterToposortToModules mg2_with_srcimps)++ let maybe_top_mod = case how_much of+ LoadUpTo m -> Just m+ LoadDependenciesOf m -> Just m+ _ -> Nothing++ build_plan = createBuildPlan mod_graph maybe_top_mod+++ let+ -- prune the HPT so everything is not retained when doing an+ -- upsweep.+ !pruned_cache = pruneCache cache+ (flattenSCCs (filterToposortToModules mg2_with_srcimps))+++ -- before we unload anything, make sure we don't leave an old+ -- interactive context around pointing to dead bindings. Also,+ -- write an empty HPT to allow the old HPT to be GC'd.++ let pruneHomeUnitEnv hme = hme { homeUnitEnv_hpt = emptyHomePackageTable }+ setSession $ discardIC $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env++ -- Unload everything+ liftIO $ unload interp hsc_env++ liftIO $ debugTraceMsg logger 2 (hang (text "Ready for upsweep")+ 2 (ppr build_plan))++ let direct_deps = mkDepsMap (mgModSummaries' mod_graph)++ n_jobs <- case parMakeCount (hsc_dflags hsc_env) of+ Nothing -> liftIO getNumProcessors+ Just n -> return n++ setSession $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env+ hsc_env <- getSession+ (upsweep_ok, hsc_env1, new_cache) <- withDeferredDiagnostics $+ liftIO $ upsweep n_jobs hsc_env mHscMessage (toCache pruned_cache) direct_deps build_plan+ setSession hsc_env1+ fmap (, new_cache) $ case upsweep_ok of+ Failed -> loadFinish upsweep_ok+ Succeeded -> do+ liftIO $ debugTraceMsg logger 2 (text "Upsweep completely successful.")+ -- Clean up after ourselves+ liftIO $ cleanCurrentModuleTempFilesMaybe logger (hsc_tmpfs hsc_env1) dflags+ loadFinish upsweep_ok++++-- | Finish up after a load.+loadFinish :: GhcMonad m => SuccessFlag -> m SuccessFlag+-- Empty the interactive context and set the module context to the topmost+-- newly loaded module, or the Prelude if none were loaded.+loadFinish all_ok+ = do modifySession discardIC+ return all_ok++-- | Discard the contents of the InteractiveContext, but keep the DynFlags and+-- the loaded plugins. It will also keep ic_int_print and ic_monad if their+-- names are from external packages.+discardIC :: HscEnv -> HscEnv+discardIC hsc_env+ = hsc_env { hsc_IC = empty_ic { ic_int_print = new_ic_int_print+ , ic_monad = new_ic_monad+ , ic_plugins = old_plugins+ } }+ where+ -- Force the new values for ic_int_print and ic_monad to avoid leaking old_ic+ !new_ic_int_print = keep_external_name ic_int_print+ !new_ic_monad = keep_external_name ic_monad+ !old_plugins = ic_plugins old_ic+ dflags = ic_dflags old_ic+ old_ic = hsc_IC hsc_env+ empty_ic = emptyInteractiveContext dflags+ keep_external_name ic_name+ | nameIsFromExternalPackage home_unit old_name = old_name+ | otherwise = ic_name empty_ic+ where+ home_unit = hsc_home_unit hsc_env+ old_name = ic_name old_ic++-- | If there is no -o option, guess the name of target executable+-- by using top-level source file name as a base.+guessOutputFile :: GhcMonad m => m ()+guessOutputFile = modifySession $ \env ->+ -- Force mod_graph to avoid leaking env+ let !mod_graph = hsc_mod_graph env+ new_home_graph =+ flip unitEnv_map (hsc_HUG env) $ \hue ->+ let dflags = homeUnitEnv_dflags hue+ platform = targetPlatform dflags+ mainModuleSrcPath :: Maybe String+ mainModuleSrcPath = do+ ms <- mgLookupModule mod_graph (mainModIs hue)+ ml_hs_file (ms_location ms)+ name = fmap dropExtension mainModuleSrcPath++ -- MP: This exception is quite sensitive to being forced, if you+ -- force it here then the error message is different because it gets+ -- caught by a different error handler than the test (T9930fail) expects.+ -- Putting an exception into DynFlags is probably not a great design but+ -- I'll write this comment rather than more eagerly force the exception.+ name_exe = do+ -- we must add the .exe extension unconditionally here, otherwise+ -- when name has an extension of its own, the .exe extension will+ -- not be added by GHC.Driver.Pipeline.exeFileName. See #2248+ !name' <- if platformOS platform == OSMinGW32+ then fmap (<.> "exe") name+ else name+ mainModuleSrcPath' <- mainModuleSrcPath+ -- #9930: don't clobber input files (unless they ask for it)+ if name' == mainModuleSrcPath'+ then throwGhcException . UsageError $+ "default output name would overwrite the input file; " +++ "must specify -o explicitly"+ else Just name'+ in+ case outputFile_ dflags of+ Just _ -> hue+ Nothing -> hue {homeUnitEnv_dflags = dflags { outputFile_ = name_exe } }+ in env { hsc_unit_env = (hsc_unit_env env) { ue_home_unit_graph = new_home_graph } }++-- -----------------------------------------------------------------------------+--+-- | Prune the HomePackageTable+--+-- Before doing an upsweep, we can throw away:+--+-- - all ModDetails, all linked code+-- - all unlinked code that is out of date with respect to+-- the source file+--+-- This is VERY IMPORTANT otherwise we'll end up requiring 2x the+-- space at the end of the upsweep, because the topmost ModDetails of the+-- old HPT holds on to the entire type environment from the previous+-- compilation.+-- Note [GHC Heap Invariants]+pruneCache :: [HomeModInfo]+ -> [ModSummary]+ -> [HomeModInfo]+pruneCache hpt summ+ = strictMap prune hpt+ where prune hmi = hmi'{ hm_details = emptyModDetails }+ where+ modl = moduleName (mi_module (hm_iface hmi))+ hmi' | Just ms <- lookupUFM ms_map modl+ , mi_src_hash (hm_iface hmi) /= ms_hs_hash ms+ = hmi{ hm_linkable = Nothing }+ | otherwise+ = hmi++ ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]++-- ---------------------------------------------------------------------------+--+-- | Unloading+unload :: Interp -> HscEnv -> IO ()+unload interp hsc_env+ = case ghcLink (hsc_dflags hsc_env) of+ LinkInMemory -> Linker.unload interp hsc_env []+ _other -> return ()+++{- Parallel Upsweep++The parallel upsweep attempts to concurrently compile the modules in the+compilation graph using multiple Haskell threads.++The Algorithm++* The list of `MakeAction`s are created by `interpretBuildPlan`. A `MakeAction` is+a pair of an `IO a` action and a `MVar a`, where to place the result.+ The list is sorted topologically, so can be executed in order without fear of+ blocking.+* runPipelines takes this list and eventually passes it to runLoop which executes+ each action and places the result into the right MVar.+* The amount of parrelism is controlled by a semaphore. This is just used around the+ module compilation step, so that only the right number of modules are compiled at+ the same time which reduces overal memory usage and allocations.+* Each proper node has a LogQueue, which dictates where to send it's output.+* The LogQueue is placed into the LogQueueQueue when the action starts and a worker+ thread processes the LogQueueQueue printing logs for each module in a stable order.+* The result variable for an action producing `a` is of type `Maybe a`, therefore+ it is still filled on a failure. If a module fails to compile, the+ failure is propagated through the whole module graph and any modules which didn't+ depend on the failure can still be compiled. This behaviour also makes the code+ quite a bit cleaner.+-}+++{-++Note [--make mode]+~~~~~~~~~~~~~~~~~++There are two main parts to `--make` mode.++1. `downsweep`: Starts from the top of the module graph and computes dependencies.+2. `upsweep`: Starts from the bottom of the module graph and compiles modules.++The result of the downsweep is a 'ModuleGraph', which is then passed to 'upsweep' which+computers how to build this ModuleGraph.++Note [Upsweep]+~~~~~~~~~~~~~~++Upsweep takes a 'ModuleGraph' as input, computes a build plan and then executes+the plan in order to compile the project.++The first step is computing the build plan from a 'ModuleGraph'.++The output of this step is a `[BuildPlan]`, which is a topologically sorted plan for+how to build all the modules.++```+data BuildPlan = SingleModule ModuleGraphNode -- A simple, single module all alone but *might* have an hs-boot file which isn't part of a cycle+ | ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBoot] -- A resolved cycle, linearised by hs-boot files+ | UnresolvedCycle [ModuleGraphNode] -- An actual cycle, which wasn't resolved by hs-boot files+```++The plan is computed in two steps:++Step 1: Topologically sort the module graph without hs-boot files. This returns a [SCC ModuleGraphNode] which contains+ cycles.+Step 2: For each cycle, topologically sort the modules in the cycle *with* the relevant hs-boot files. This should+ result in an acyclic build plan if the hs-boot files are sufficient to resolve the cycle.+Step 2a: For each module in the cycle, if the module has a boot file then compute the+ modules on the path between it and the hs-boot file. This information is+ stored in ModuleGraphNodeWithBoot.++The `[BuildPlan]` is then interpreted by the `interpretBuildPlan` function.++* SingleModule nodes are compiled normally by either the upsweep_inst or upsweep_mod functions.+* ResolvedCycles need to compiled "together" so that modules outside the cycle are presented+ with a consistent knot-tied version of modules at the end.+ - When the ModuleGraphNodeWithBoot nodes are compiled then suitable rehydration+ is performed both before and after the module in question is compiled.+ See Note [Hydrating Modules] for more information.+* UnresolvedCycles are indicative of a proper cycle, unresolved by hs-boot files+ and are reported as an error to the user.++The main trickiness of `interpretBuildPlan` is deciding which version of a dependency+is visible from each module. For modules which are not in a cycle, there is just+one version of a module, so that is always used. For modules in a cycle, there are two versions of+'HomeModInfo'.++1. Internal to loop: The version created whilst compiling the loop by upsweep_mod.+2. External to loop: The knot-tied version created by typecheckLoop.++Whilst compiling a module inside the loop, we need to use the (1). For a module which+is outside of the loop which depends on something from in the loop, the (2) version+is used.++As the plan is interpreted, which version of a HomeModInfo is visible is updated+by updating a map held in a state monad. So after a loop has finished being compiled,+the visible module is the one created by typecheckLoop and the internal version is not+used again.++This plan also ensures the most important invariant to do with module loops:++> If you depend on anything within a module loop, before you can use the dependency,+ the whole loop has to finish compiling.++The end result of `interpretBuildPlan` is a `[MakeAction]`, which are pairs+of `IO a` actions and a `MVar (Maybe a)`, somewhere to put the result of running+the action. This list is topologically sorted, so can be run in order to compute+the whole graph.++As well as this `interpretBuildPlan` also outputs an `IO [Maybe (Maybe HomeModInfo)]` which+can be queried at the end to get the result of all modules at the end, with their proper+visibility. For example, if any module in a loop fails then all modules in that loop will+report as failed because the visible node at the end will be the result of checking+these modules together.++-}++-- | Simple wrapper around MVar which allows a functor instance.+data ResultVar b = forall a . ResultVar (a -> b) (MVar (Maybe a))++instance Functor ResultVar where+ fmap f (ResultVar g var) = ResultVar (f . g) var++mkResultVar :: MVar (Maybe a) -> ResultVar a+mkResultVar = ResultVar id++-- | Block until the result is ready.+waitResult :: ResultVar a -> MaybeT IO a+waitResult (ResultVar f var) = MaybeT (fmap f <$> readMVar var)+++data BuildLoopState = BuildLoopState { buildDep :: M.Map NodeKey (SDoc, ResultVar (Maybe HomeModInfo))+ -- The current way to build a specific TNodeKey, without cycles this just points to+ -- the appropiate result of compiling a module but with+ -- cycles there can be additional indirection and can point to the result of typechecking a loop+ , nNODE :: Int+ , hug_var :: MVar HomeUnitGraph+ -- A global variable which is incrementally updated with the result+ -- of compiling modules.+ }++nodeId :: BuildM Int+nodeId = do+ n <- gets nNODE+ modify (\m -> m { nNODE = n + 1 })+ return n++setModulePipeline :: NodeKey -> SDoc -> ResultVar (Maybe HomeModInfo) -> BuildM ()+setModulePipeline mgn doc wrapped_pipeline = do+ modify (\m -> m { buildDep = M.insert mgn (doc, wrapped_pipeline) (buildDep m) })++getBuildMap :: BuildM (M.Map+ NodeKey (SDoc, ResultVar (Maybe HomeModInfo)))+getBuildMap = gets buildDep++type BuildM a = StateT BuildLoopState IO a+++-- | Abstraction over the operations of a semaphore which allows usage with the+-- -j1 case+data AbstractSem = AbstractSem { acquireSem :: IO ()+ , releaseSem :: IO () }++withAbstractSem :: AbstractSem -> IO b -> IO b+withAbstractSem sem = MC.bracket_ (acquireSem sem) (releaseSem sem)++-- | Environment used when compiling a module+data MakeEnv = MakeEnv { hsc_env :: !HscEnv -- The basic HscEnv which will be augmented for each module+ , compile_sem :: !AbstractSem+ -- Modify the environment for module k, with the supplied logger modification function.+ -- For -j1, this wrapper doesn't do anything+ -- For -jn, the wrapper initialised a log queue and then modifies the logger to pipe its output+ -- into the log queue.+ , withLogger :: forall a . Int -> ((Logger -> Logger) -> IO a) -> IO a+ , env_messager :: !(Maybe Messager)+ }++type RunMakeM a = ReaderT MakeEnv (MaybeT IO) a++-- | Given the build plan, creates a graph which indicates where each NodeKey should+-- get its direct dependencies from. This might not be the corresponding build action+-- if the module participates in a loop. This step also labels each node with a number for the output.+-- See Note [Upsweep] for a high-level description.+interpretBuildPlan :: HomeUnitGraph+ -> M.Map ModNodeKeyWithUid HomeModInfo+ -> (NodeKey -> [NodeKey])+ -> [BuildPlan]+ -> IO ( Maybe [ModuleGraphNode] -- Is there an unresolved cycle+ , [MakeAction] -- Actions we need to run in order to build everything+ , IO [Maybe (Maybe HomeModInfo)]) -- An action to query to get all the built modules at the end.+interpretBuildPlan hug old_hpt deps_map plan = do+ hug_var <- newMVar hug+ ((mcycle, plans), build_map) <- runStateT (buildLoop plan) (BuildLoopState M.empty 1 hug_var)+ return (mcycle, plans, collect_results (buildDep build_map))++ where+ collect_results build_map = mapM (\(_doc, res_var) -> runMaybeT (waitResult res_var)) (M.elems build_map)++ n_mods = sum (map countMods plan)++ buildLoop :: [BuildPlan]+ -> BuildM (Maybe [ModuleGraphNode], [MakeAction])+ -- Build the abstract pipeline which we can execute+ -- Building finished+ buildLoop [] = return (Nothing, [])+ buildLoop (plan:plans) =+ case plan of+ -- If there was no cycle, then typecheckLoop is not necessary+ SingleModule m -> do+ (one_plan, _) <- buildSingleModule Nothing m+ (cycle, all_plans) <- buildLoop plans+ return (cycle, one_plan : all_plans)++ -- For a resolved cycle, depend on everything in the loop, then update+ -- the cache to point to this node rather than directly to the module build+ -- nodes+ ResolvedCycle ms -> do+ pipes <- buildModuleLoop ms+ (cycle, graph) <- buildLoop plans+ return (cycle, pipes ++ graph)++ -- Can't continue past this point as the cycle is unresolved.+ UnresolvedCycle ns -> return (Just ns, [])++ buildSingleModule :: Maybe [ModuleGraphNode] -- Modules we need to rehydrate before compiling this module+ -> ModuleGraphNode -- The node we are compiling+ -> BuildM (MakeAction, ResultVar (Maybe HomeModInfo))+ buildSingleModule rehydrate_nodes mod = do+ mod_idx <- nodeId+ home_mod_map <- getBuildMap+ hug_var <- gets hug_var+ -- 1. Get the transitive dependencies of this module, by looking up in the dependency map+ let direct_deps = deps_map (mkNodeKey mod)+ doc_build_deps = map (expectJust "dep_map" . flip M.lookup home_mod_map) direct_deps+ build_deps = map snd doc_build_deps+ -- 2. Set the default way to build this node, not in a loop here+ let build_action = withCurrentUnit (moduleGraphNodeUnitId mod) $+ case mod of+ InstantiationNode uid iu ->+ const Nothing <$> executeInstantiationNode mod_idx n_mods (wait_deps_hug hug_var build_deps) uid iu+ ModuleNode build_deps ms -> do+ let !old_hmi = M.lookup (msKey ms) old_hpt+ rehydrate_mods = mapMaybe moduleGraphNodeModule <$> rehydrate_nodes+ build_deps_vars = map snd $ map (expectJust "build_deps" . flip M.lookup home_mod_map) build_deps+ hmi <- executeCompileNode mod_idx n_mods old_hmi (wait_deps_hug hug_var build_deps_vars) rehydrate_mods ms+ -- This global MVar is incrementally modified in order to avoid having to+ -- recreate the HPT before compiling each module which leads to a quadratic amount of work.+ hsc_env <- asks hsc_env+ hmi' <- liftIO $ modifyMVar hug_var (\hug -> do+ let new_hpt = addHomeModInfoToHug hmi hug+ new_hsc = setHUG new_hpt hsc_env+ maybeRehydrateAfter hmi new_hsc rehydrate_mods+ )+ return (Just hmi')+ LinkNode nks uid -> do+ let link_deps = map snd $ map (\nk -> expectJust "build_deps_link" . flip M.lookup home_mod_map $ nk) nks+ executeLinkNode (wait_deps_hug hug_var link_deps) (mod_idx, n_mods) uid nks+ return Nothing+++ res_var <- liftIO newEmptyMVar+ let result_var = mkResultVar res_var+ setModulePipeline (mkNodeKey mod) (text "N") result_var+ return $ (MakeAction build_action res_var, result_var)+++ buildOneLoopyModule :: ModuleGraphNodeWithBootFile -> BuildM (MakeAction, (ResultVar (Maybe HomeModInfo)))+ buildOneLoopyModule (ModuleGraphNodeWithBootFile mn deps) =+ buildSingleModule (Just deps) mn++ buildModuleLoop :: [Either ModuleGraphNode ModuleGraphNodeWithBootFile] -> BuildM [MakeAction]+ buildModuleLoop ms = do+ (build_modules, wait_modules) <- mapAndUnzipM (either (buildSingleModule Nothing) buildOneLoopyModule) ms+ res_var <- liftIO newEmptyMVar+ let loop_action = wait_deps wait_modules+ let fanout i = Just . (!! i) <$> mkResultVar res_var+ -- From outside the module loop, anyone must wait for the loop to finish and then+ -- use the result of the rehydrated iface. This makes sure that things not in the+ -- module loop will see the updated interfaces for all the identifiers in the loop.+ let update_module_pipeline (m, i) = setModulePipeline (NodeKey_Module m) (text "T") (fanout i)++ let ms_i = zip (mapMaybe (fmap msKey . moduleGraphNodeModSum . either id getNode) ms) [0..]+ mapM update_module_pipeline ms_i+ return $ build_modules ++ [MakeAction loop_action res_var]+++withCurrentUnit :: UnitId -> RunMakeM a -> RunMakeM a+withCurrentUnit uid = do+ local (\env -> env { hsc_env = hscSetActiveUnitId uid (hsc_env env)})+++upsweep+ :: Int -- ^ The number of workers we wish to run in parallel+ -> HscEnv -- ^ The base HscEnv, which is augmented for each module+ -> Maybe Messager+ -> M.Map ModNodeKeyWithUid HomeModInfo+ -> (NodeKey -> [NodeKey]) -- A function which computes the direct dependencies of a NodeKey+ -> [BuildPlan]+ -> IO (SuccessFlag, HscEnv, [HomeModInfo])+upsweep n_jobs hsc_env mHscMessage old_hpt direct_deps build_plan = do+ (cycle, pipelines, collect_result) <- interpretBuildPlan (hsc_HUG hsc_env) old_hpt direct_deps build_plan+ runPipelines n_jobs hsc_env mHscMessage pipelines+ res <- collect_result++ let completed = [m | Just (Just m) <- res]+ let hsc_env' = addDepsToHscEnv completed hsc_env++ -- Handle any cycle in the original compilation graph and return the result+ -- of the upsweep.+ case cycle of+ Just mss -> do+ let logger = hsc_logger hsc_env+ liftIO $ fatalErrorMsg logger (cyclicModuleErr mss)+ return (Failed, hsc_env, completed)+ Nothing -> do+ let success_flag = successIf (all isJust res)+ return (success_flag, hsc_env', completed)++toCache :: [HomeModInfo] -> M.Map (ModNodeKeyWithUid) HomeModInfo+toCache hmis = M.fromList ([(miKey $ hm_iface hmi, hmi) | hmi <- hmis])++miKey :: ModIface -> ModNodeKeyWithUid+miKey hmi = ModNodeKeyWithUid (mi_mnwib hmi) ((toUnitId $ moduleUnit (mi_module hmi)))++upsweep_inst :: HscEnv+ -> Maybe Messager+ -> Int -- index of module+ -> Int -- total number of modules+ -> UnitId+ -> InstantiatedUnit+ -> IO ()+upsweep_inst hsc_env mHscMessage mod_index nmods uid iuid = do+ case mHscMessage of+ Just hscMessage -> hscMessage hsc_env (mod_index, nmods) MustCompile (InstantiationNode uid iuid)+ Nothing -> return ()+ runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ tcRnCheckUnit hsc_env $ VirtUnit iuid+ pure ()++-- | Compile a single module. Always produce a Linkable for it if+-- successful. If no compilation happened, return the old Linkable.+upsweep_mod :: HscEnv+ -> Maybe Messager+ -> Maybe HomeModInfo+ -> ModSummary+ -> Int -- index of module+ -> Int -- total number of modules+ -> IO HomeModInfo+upsweep_mod hsc_env mHscMessage old_hmi summary mod_index nmods = do+ hmi <- compileOne' mHscMessage hsc_env summary+ mod_index nmods (hm_iface <$> old_hmi) (old_hmi >>= hm_linkable)++ -- MP: This is a bit janky, because before you add the entries you have to extend the HPT with the module+ -- you just compiled. Another option, would be delay adding anything until after upsweep has finished, but I+ -- am unsure if this is sound (wrt running TH splices for example).+ -- This function only does anything if the linkable produced is a BCO, which only happens with the+ -- bytecode backend, no need to guard against the backend type additionally.+ addSptEntries (hscUpdateHPT (\hpt -> addToHpt hpt (ms_mod_name summary) hmi) hsc_env)+ (ms_mnwib summary)+ (hm_linkable hmi)++ return hmi++-- | Add the entries from a BCO linkable to the SPT table, see+-- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.+addSptEntries :: HscEnv -> ModuleNameWithIsBoot -> Maybe Linkable -> IO ()+addSptEntries hsc_env mnwib mlinkable =+ hscAddSptEntries hsc_env (Just mnwib)+ [ spt+ | Just linkable <- [mlinkable]+ , unlinked <- linkableUnlinked linkable+ , BCOs _ spts <- pure unlinked+ , spt <- spts+ ]++{- Note [-fno-code mode]+~~~~~~~~~~~~~~~~~~~~~~~~+GHC offers the flag -fno-code for the purpose of parsing and typechecking a+program without generating object files. This is intended to be used by tooling+and IDEs to provide quick feedback on any parser or type errors as cheaply as+possible.++When GHC is invoked with -fno-code no object files or linked output will be+generated. As many errors and warnings as possible will be generated, as if+-fno-code had not been passed. The session DynFlags will have+backend == NoBackend.++-fwrite-interface+~~~~~~~~~~~~~~~~+Whether interface files are generated in -fno-code mode is controlled by the+-fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is+not also passed. Recompilation avoidance requires interface files, so passing+-fno-code without -fwrite-interface should be avoided. If -fno-code were+re-implemented today, -fwrite-interface would be discarded and it would be+considered always on; this behaviour is as it is for backwards compatibility.++================================================================+IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER+================================================================++Template Haskell+~~~~~~~~~~~~~~~~+A module using template haskell may invoke an imported function from inside a+splice. This will cause the type-checker to attempt to execute that code, which+would fail if no object files had been generated. See #8025. To rectify this,+during the downsweep we patch the DynFlags in the ModSummary of any home module+that is imported by a module that uses template haskell, to generate object+code.++The flavour of generated object code is chosen by defaultObjectTarget for the+target platform. It would likely be faster to generate bytecode, but this is not+supported on all platforms(?Please Confirm?), and does not support the entirety+of GHC haskell. See #1257.++The object files (and interface files if -fwrite-interface is disabled) produced+for template haskell are written to temporary files.++Note that since template haskell can run arbitrary IO actions, -fno-code mode+is no more secure than running without it.++Potential TODOS:+~~~~~+* Remove -fwrite-interface and have interface files always written in -fno-code+ mode+* Both .o and .dyn_o files are generated for template haskell, but we only need+ .dyn_o. Fix it.+* In make mode, a message like+ Compiling A (A.hs, /tmp/ghc_123.o)+ is shown if downsweep enabled object code generation for A. Perhaps we should+ show "nothing" or "temporary object file" instead. Note that one+ can currently use -keep-tmp-files and inspect the generated file with the+ current behaviour.+* Offer a -no-codedir command line option, and write what were temporary+ object files there. This would speed up recompilation.+* Use existing object files (if they are up to date) instead of always+ generating temporary ones.+-}++-- Note [When source is considered modified]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- A number of functions in GHC.Driver accept a SourceModified argument, which+-- is part of how GHC determines whether recompilation may be avoided (see the+-- definition of the SourceModified data type for details).+--+-- Determining whether or not a source file is considered modified depends not+-- only on the source file itself, but also on the output files which compiling+-- that module would produce. This is done because GHC supports a number of+-- flags which control which output files should be produced, e.g. -fno-code+-- -fwrite-interface and -fwrite-ide-file; we must check not only whether the+-- source file has been modified since the last compile, but also whether the+-- source file has been modified since the last compile which produced all of+-- the output files which have been requested.+--+-- Specifically, a source file is considered unmodified if it is up-to-date+-- relative to all of the output files which have been requested. Whether or+-- not an output file is up-to-date depends on what kind of file it is:+--+-- * iface (.hi) files are considered up-to-date if (and only if) their+-- mi_src_hash field matches the hash of the source file,+--+-- * all other output files (.o, .dyn_o, .hie, etc) are considered up-to-date+-- if (and only if) their modification times on the filesystem are greater+-- than or equal to the modification time of the corresponding .hi file.+--+-- Why do we use '>=' rather than '>' for output files other than the .hi file?+-- If the filesystem has poor resolution for timestamps (e.g. FAT32 has a+-- resolution of 2 seconds), we may often find that the .hi and .o files have+-- the same modification time. Using >= is slightly unsafe, but it matches+-- make's behaviour.+--+-- This strategy allows us to do the minimum work necessary in order to ensure+-- that all the files the user cares about are up-to-date; e.g. we should not+-- worry about .o files if the user has indicated that they are not interested+-- in them via -fno-code. See also #9243.+--+-- Note that recompilation avoidance is dependent on .hi files being produced,+-- which does not happen if -fno-write-interface -fno-code is passed. That is,+-- passing -fno-write-interface -fno-code means that you cannot benefit from+-- recompilation avoidance. See also Note [-fno-code mode].+--+-- The correctness of this strategy depends on an assumption that whenever we+-- are producing multiple output files, the .hi file is always written first.+-- If this assumption is violated, we risk recompiling unnecessarily by+-- incorrectly regarding non-.hi files as outdated.+--++-- ---------------------------------------------------------------------------+--+-- | Topological sort of the module graph+topSortModuleGraph+ :: Bool+ -- ^ Drop hi-boot nodes? (see below)+ -> ModuleGraph+ -> Maybe HomeUnitModule+ -- ^ Root module name. If @Nothing@, use the full graph.+ -> [SCC ModuleGraphNode]+-- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes+-- The resulting list of strongly-connected-components is in topologically+-- sorted order, starting with the module(s) at the bottom of the+-- dependency graph (ie compile them first) and ending with the ones at+-- the top.+--+-- Drop hi-boot nodes (first boolean arg)?+--+-- - @False@: treat the hi-boot summaries as nodes of the graph,+-- so the graph must be acyclic+--+-- - @True@: eliminate the hi-boot nodes, and instead pretend+-- the a source-import of Foo is an import of Foo+-- The resulting graph has no hi-boot nodes, but can be cyclic+topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod =+ -- stronglyConnCompG flips the original order, so if we reverse+ -- the summaries we get a stable topological sort.+ topSortModules drop_hs_boot_nodes (reverse $ mgModSummaries' module_graph) mb_root_mod++topSortModules :: Bool -> [ModuleGraphNode] -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]+topSortModules drop_hs_boot_nodes summaries mb_root_mod+ = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph+ where+ (graph, lookup_node) =+ moduleGraphNodes drop_hs_boot_nodes summaries++ initial_graph = case mb_root_mod of+ Nothing -> graph+ Just (Module uid root_mod) ->+ -- restrict the graph to just those modules reachable from+ -- the specified module. We do this by building a graph with+ -- the full set of nodes, and determining the reachable set from+ -- the specified node.+ let root | Just node <- lookup_node $ NodeKey_Module $ ModNodeKeyWithUid (GWIB root_mod NotBoot) uid+ , graph `hasVertexG` node+ = node+ | otherwise+ = throwGhcException (ProgramError "module does not exist")+ in graphFromEdgedVerticesUniq (seq root (reachableG graph root))++newtype ModNodeMap a = ModNodeMap { unModNodeMap :: Map.Map ModNodeKey a }+ deriving (Functor, Traversable, Foldable)++emptyModNodeMap :: ModNodeMap a+emptyModNodeMap = ModNodeMap Map.empty++modNodeMapInsert :: ModNodeKey -> a -> ModNodeMap a -> ModNodeMap a+modNodeMapInsert k v (ModNodeMap m) = ModNodeMap (Map.insert k v m)++modNodeMapElems :: ModNodeMap a -> [a]+modNodeMapElems (ModNodeMap m) = Map.elems m++modNodeMapLookup :: ModNodeKey -> ModNodeMap a -> Maybe a+modNodeMapLookup k (ModNodeMap m) = Map.lookup k m++modNodeMapSingleton :: ModNodeKey -> a -> ModNodeMap a+modNodeMapSingleton k v = ModNodeMap (M.singleton k v)++modNodeMapUnionWith :: (a -> a -> a) -> ModNodeMap a -> ModNodeMap a -> ModNodeMap a+modNodeMapUnionWith f (ModNodeMap m) (ModNodeMap n) = ModNodeMap (M.unionWith f m n)++-- | Efficiently construct a map from a NodeKey to its list of transitive dependencies+mkDepsMap :: [ModuleGraphNode] -> (NodeKey -> [NodeKey])+mkDepsMap nodes =+ -- Important that we force this before returning a lambda so we can share the module graph+ -- for each node+ let !(mg, lookup_node) = moduleGraphNodes False nodes+ in \nk -> map (mkNodeKey . node_payload) $ outgoingG mg (expectJust "mkDepsMap" (lookup_node nk))++-- | If there are {-# SOURCE #-} imports between strongly connected+-- components in the topological sort, then those imports can+-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE+-- were necessary, then the edge would be part of a cycle.+warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()+warnUnnecessarySourceImports sccs = do+ diag_opts <- initDiagOpts <$> getDynFlags+ when (diag_wopt Opt_WarnUnusedImports diag_opts) $ do+ let check ms =+ let mods_in_this_cycle = map ms_mod_name ms in+ [ warn i | m <- ms, i <- ms_home_srcimps m,+ unLoc i `notElem` mods_in_this_cycle ]++ warn :: Located ModuleName -> MsgEnvelope GhcMessage+ warn (L loc mod) = GhcDriverMessage <$> mkPlainMsgEnvelope diag_opts+ loc (DriverUnnecessarySourceImports mod)+ logDiagnostics (mkMessages $ listToBag (concatMap (check . flattenSCC) sccs))+++-- This caches the answer to the question, if we are in this unit, what does+-- an import of this module mean.+type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModSummary]++-----------------------------------------------------------------------------+--+-- | Downsweep (dependency analysis)+--+-- Chase downwards from the specified root set, returning summaries+-- for all home modules encountered. Only follow source-import+-- links.+--+-- We pass in the previous collection of summaries, which is used as a+-- cache to avoid recalculating a module summary if the source is+-- unchanged.+--+-- The returned list of [ModSummary] nodes has one node for each home-package+-- module, plus one for any hs-boot files. The imports of these nodes+-- are all there, including the imports of non-home-package modules.+downsweep :: HscEnv+ -> [ModSummary]+ -- ^ Old summaries+ -> [ModuleName] -- Ignore dependencies on these; treat+ -- them as if they were package modules+ -> Bool -- True <=> allow multiple targets to have+ -- the same module name; this is+ -- very useful for ghc -M+ -> IO ([DriverMessages], [ModuleGraphNode])+ -- The non-error elements of the returned list all have distinct+ -- (Modules, IsBoot) identifiers, unless the Bool is true in+ -- which case there can be repeats+downsweep hsc_env old_summaries excl_mods allow_dup_roots+ = do+ rootSummaries <- mapM getRootSummary roots+ 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)+ let unit_env = hsc_unit_env hsc_env+ let tmpfs = hsc_tmpfs hsc_env++ let downsweep_errs = lefts $ concat $ M.elems map0+ downsweep_nodes = M.elems deps++ (other_errs, unit_nodes) = partitionEithers $ unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env)+ all_nodes = downsweep_nodes ++ unit_nodes+ all_errs = all_root_errs ++ downsweep_errs ++ other_errs+ all_root_errs = closure_errs ++ map snd root_errs++ -- if we have been passed -fno-code, we enable code generation+ -- for dependencies of modules that have -XTemplateHaskell,+ -- otherwise those modules will fail to compile.+ -- See Note [-fno-code mode] #8025+ th_enabled_nodes <- case backend dflags of+ NoBackend -> enableCodeGenForTH logger tmpfs unit_env all_nodes+ _ -> return all_nodes+ if null all_root_errs+ then return (all_errs, th_enabled_nodes)+ else pure $ (all_root_errs, [])+ where+ -- Dependencies arising on a unit (backpack and module linking deps)+ unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode]+ unitModuleNodes summaries uid hue =+ let instantiation_nodes = instantiationNodes uid (homeUnitEnv_units hue)+ in map Right instantiation_nodes+ ++ maybeToList (linkNodes (instantiation_nodes ++ summaries) uid hue)++ calcDeps ms = [(ms_unitid ms, b, c) | (b, c) <- msDeps ms ]++ dflags = hsc_dflags hsc_env+ logger = hsc_logger hsc_env+ roots = hsc_targets hsc_env++ -- A cache from file paths to the already summarised modules.+ -- Reuse these if we can because the most expensive part of downsweep is+ -- reading the headers.+ old_summary_map :: M.Map FilePath ModSummary+ old_summary_map = M.fromList [(msHsFilePath ms, ms) | ms <- old_summaries]++ getRootSummary :: Target -> IO (Either (UnitId, DriverMessages) ModSummary)+ getRootSummary Target { targetId = TargetFile file mb_phase+ , targetContents = maybe_buf+ , targetUnitId = uid+ }+ = do let offset_file = augmentByWorkingDirectory dflags file+ exists <- liftIO $ doesFileExist offset_file+ if exists || isJust maybe_buf+ then first (uid,) <$>+ summariseFile hsc_env home_unit old_summary_map offset_file mb_phase+ maybe_buf+ else return $ Left $ (uid,) $ singleMessage+ $ mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound offset_file)+ where+ dflags = homeUnitEnv_dflags (ue_findHomeUnitEnv uid (hsc_unit_env hsc_env))+ home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env)+ getRootSummary Target { targetId = TargetModule modl+ , targetContents = maybe_buf+ , targetUnitId = uid+ }+ = do maybe_summary <- summariseModule hsc_env home_unit old_summary_map NotBoot+ (L rootLoc modl) (ThisPkg (homeUnitId home_unit))+ maybe_buf excl_mods+ case maybe_summary of+ FoundHome s -> return (Right s)+ FoundHomeWithError err -> return (Left err)+ _ -> return $ Left $ (uid, moduleNotFoundErr modl)+ where+ home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env)+ rootLoc = mkGeneralSrcSpan (fsLit "<command line>")++ -- In a root module, the filename is allowed to diverge from the module+ -- name, so we have to check that there aren't multiple root files+ -- defining the same module (otherwise the duplicates will be silently+ -- ignored, leading to confusing behaviour).+ checkDuplicates+ :: DownsweepCache+ -> IO ()+ checkDuplicates root_map+ | allow_dup_roots = return ()+ | null dup_roots = return ()+ | otherwise = liftIO $ multiRootsErr (head dup_roots)+ where+ dup_roots :: [[ModSummary]] -- Each at least of length 2+ dup_roots = filterOut isSingleton $ map rights (M.elems root_map)++ -- 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),+ DownsweepCache)+ -> IO ((M.Map NodeKey ModuleGraphNode), Set.Set (UnitId, UnitId), DownsweepCache)+ loopSummaries [] done = return done+ loopSummaries (ms:next) (done, pkgs, summarised)+ | Just {} <- M.lookup k done+ = loopSummaries next (done, pkgs, 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+ -- 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'')+ where+ k = NodeKey_Module (msKey ms)++ hs_file_for_boot+ | HsBootFile <- ms_hsc_src ms = Just $ ((ms_unitid ms), NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot))+ | otherwise = Nothing+++ -- This loops over each import in each summary. It is mutually recursive with loopSummaries if we discover+ -- a new module by doing this.+ loopImports :: [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]+ -- Work list: process these modules+ -> M.Map NodeKey ModuleGraphNode+ -> DownsweepCache+ -- 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),++ M.Map NodeKey ModuleGraphNode, DownsweepCache)+ -- The result is the completed NodeMap+ loopImports [] done summarised = return ([], Set.empty, 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')+ [Left _err] ->+ loopImports ss done summarised+ _errs -> do+ loopImports ss done summarised+ | otherwise+ = do+ mb_s <- summariseModule hsc_env home_unit old_summary_map+ is_boot wanted_mod mb_pkg+ 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')+ FoundInstantiation iud -> do+ (other_deps, pkgs, done', summarised') <- loopImports ss done summarised+ return (NodeKey_Unit iud : other_deps, pkgs, 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'++ -- 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)+ 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+-- 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)]++ where+ 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++-- | Update the every ModSummary that is depended on+-- by a module that needs template haskell. We enable codegen to+-- the specified target, disable optimization and change the .hi+-- and .o file locations to be temporary files.+-- See Note [-fno-code mode]+enableCodeGenForTH+ :: Logger+ -> TmpFs+ -> UnitEnv+ -> [ModuleGraphNode]+ -> IO [ModuleGraphNode]+enableCodeGenForTH logger tmpfs unit_env =+ enableCodeGenWhen logger tmpfs condition should_modify TFL_CurrentModule TFL_GhcSession unit_env+ where+ condition = isTemplateHaskellOrQQNonBoot+ should_modify ms@(ModSummary { ms_hspp_opts = dflags }) =+ backend dflags == NoBackend &&+ -- Don't enable codegen for TH on indefinite packages; we+ -- can't compile anything anyway! See #16219.+ isHomeUnitDefinite (ue_unitHomeUnit (ms_unitid ms) unit_env)++-- | Helper used to implement 'enableCodeGenForTH'.+-- In particular, this enables+-- unoptimized code generation for all modules that meet some+-- condition (first parameter), or are dependencies of those+-- modules. The second parameter is a condition to check before+-- marking modules for code generation.+enableCodeGenWhen+ :: Logger+ -> TmpFs+ -> (ModSummary -> Bool)+ -> (ModSummary -> Bool)+ -> TempFileLifetime+ -> TempFileLifetime+ -> UnitEnv+ -> [ModuleGraphNode]+ -> IO [ModuleGraphNode]+enableCodeGenWhen logger tmpfs condition should_modify staticLife dynLife unit_env mod_graph =+ mapM enable_code_gen mod_graph+ where+ defaultBackendOf ms = platformDefaultBackend (targetPlatform $ ue_unitFlags (ms_unitid ms) unit_env)+ enable_code_gen :: ModuleGraphNode -> IO ModuleGraphNode+ enable_code_gen n@(ModuleNode deps ms)+ | ModSummary+ { ms_location = ms_location+ , ms_hsc_src = HsSrcFile+ , ms_hspp_opts = dflags+ } <- ms+ , should_modify ms+ , mkNodeKey n `Set.member` needs_codegen_set+ = do+ let new_temp_file suf dynsuf = do+ tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf+ let dyn_tn = tn -<.> dynsuf+ addFilesToClean tmpfs dynLife [dyn_tn]+ return (tn, dyn_tn)+ -- We don't want to create .o or .hi files unless we have been asked+ -- to by the user. But we need them, so we patch their locations in+ -- the ModSummary with temporary files.+ --+ ((hi_file, dyn_hi_file), (o_file, dyn_o_file)) <-+ -- If ``-fwrite-interface` is specified, then the .o and .hi files+ -- are written into `-odir` and `-hidir` respectively. #16670+ if gopt Opt_WriteInterface dflags+ then return ((ml_hi_file ms_location, ml_dyn_hi_file ms_location)+ , (ml_obj_file ms_location, ml_dyn_obj_file ms_location))+ else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags))+ <*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags))+ let ms' = ms+ { ms_location =+ ms_location { ml_hi_file = hi_file+ , ml_obj_file = o_file+ , ml_dyn_hi_file = dyn_hi_file+ , ml_dyn_obj_file = dyn_o_file }+ , ms_hspp_opts = updOptLevel 0 $ dflags {backend = defaultBackendOf ms}+ }+ pure (ModuleNode deps ms')+ enable_code_gen ms = return ms+++ (mg, lookup_node) = moduleGraphNodes False mod_graph+ needs_codegen_set = Set.fromList $ map (mkNodeKey . node_payload) $ reachablesG mg (map (expectJust "needs_th" . lookup_node) has_th_set)+++ has_th_set =+ [ mkNodeKey mn+ | mn@(ModuleNode _ ms) <- mod_graph+ , condition ms+ ]++-- | Populate the Downsweep cache with the root modules.+mkRootMap+ :: [ModSummary]+ -> DownsweepCache+mkRootMap summaries = Map.fromListWith (flip (++))+ [ ((ms_unitid s, NoPkgQual, ms_mnwib s), [Right s]) | s <- summaries ]++-----------------------------------------------------------------------------+-- Summarising modules++-- We have two types of summarisation:+--+-- * Summarise a file. This is used for the root module(s) passed to+-- cmLoadModules. The file is read, and used to determine the root+-- module name. The module name may differ from the filename.+--+-- * Summarise a module. We are given a module name, and must provide+-- a summary. The finder is used to locate the file in which the module+-- resides.++summariseFile+ :: HscEnv+ -> HomeUnit+ -> M.Map FilePath ModSummary -- old summaries+ -> FilePath -- source file name+ -> Maybe Phase -- start phase+ -> Maybe (StringBuffer,UTCTime)+ -> IO (Either DriverMessages ModSummary)++summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf+ -- we can use a cached summary if one is available and the+ -- source file hasn't changed, But we have to look up the summary+ -- by source file, rather than module name as we do in summarise.+ | Just old_summary <- M.lookup src_fn old_summaries+ = do+ let location = ms_location $ old_summary++ src_hash <- get_src_hash+ -- The file exists; we checked in getRootSummary above.+ -- If it gets removed subsequently, then this+ -- getFileHash may fail, but that's the right+ -- behaviour.++ -- return the cached summary if the source didn't change+ checkSummaryHash+ hsc_env (new_summary src_fn)+ old_summary location src_hash++ | otherwise+ = do src_hash <- get_src_hash+ new_summary src_fn src_hash+ where+ -- change the main active unit so all operations happen relative to the given unit+ hsc_env = hscSetActiveHomeUnit home_unit hsc_env'+ -- src_fn does not necessarily exist on the filesystem, so we need to+ -- check what kind of target we are dealing with+ get_src_hash = case maybe_buf of+ Just (buf,_) -> return $ fingerprintStringBuffer buf+ Nothing -> liftIO $ getFileHash src_fn++ new_summary src_fn src_hash = runExceptT $ do+ preimps@PreprocessedImports {..}+ <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf++ let fopts = initFinderOpts (hsc_dflags hsc_env)++ -- Make a ModLocation for this file+ let location = mkHomeModLocation fopts pi_mod_name src_fn++ -- Tell the Finder cache where it is, so that subsequent calls+ -- to findModule will find it, even if it's not on any search path+ mod <- liftIO $ do+ let home_unit = hsc_home_unit hsc_env+ let fc = hsc_FC hsc_env+ addHomeModuleToFinder fc home_unit pi_mod_name location++ liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary+ { nms_src_fn = src_fn+ , nms_src_hash = src_hash+ , nms_is_boot = NotBoot+ , nms_hsc_src =+ if isHaskellSigFilename src_fn+ then HsigFile+ else HsSrcFile+ , nms_location = location+ , nms_mod = mod+ , nms_preimps = preimps+ }++checkSummaryHash+ :: HscEnv+ -> (Fingerprint -> IO (Either e ModSummary))+ -> ModSummary -> ModLocation -> Fingerprint+ -> IO (Either e ModSummary)+checkSummaryHash+ hsc_env new_summary+ old_summary+ location src_hash+ | ms_hs_hash old_summary == src_hash &&+ not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do+ -- update the object-file timestamp+ obj_timestamp <- modificationTimeIfExists (ml_obj_file location)++ -- We have to repopulate the Finder's cache for file targets+ -- because the file might not even be on the regular search path+ -- and it was likely flushed in depanal. This is not technically+ -- needed when we're called from sumariseModule but it shouldn't+ -- hurt.+ -- Also, only add to finder cache for non-boot modules as the finder cache+ -- makes sure to add a boot suffix for boot files.+ _ <- do+ let fc = hsc_FC hsc_env+ case ms_hsc_src old_summary of+ HsSrcFile -> addModuleToFinder fc (ms_mod old_summary) location+ _ -> return ()++ hi_timestamp <- modificationTimeIfExists (ml_hi_file location)+ hie_timestamp <- modificationTimeIfExists (ml_hie_file location)++ return $ Right+ ( old_summary+ { ms_obj_date = obj_timestamp+ , ms_iface_date = hi_timestamp+ , ms_hie_date = hie_timestamp+ }+ )++ | otherwise =+ -- source changed: re-summarise.+ new_summary src_hash++data SummariseResult =+ FoundInstantiation InstantiatedUnit+ | FoundHomeWithError (UnitId, DriverMessages)+ | FoundHome ModSummary+ | External UnitId+ | NotThere++-- Summarise a module, and pick up source and timestamp.+summariseModule+ :: HscEnv+ -> HomeUnit+ -> M.Map FilePath ModSummary+ -- ^ Map of old summaries+ -> IsBootInterface -- True <=> a {-# SOURCE #-} import+ -> Located ModuleName -- Imported module to be summarised+ -> PkgQual+ -> Maybe (StringBuffer, UTCTime)+ -> [ModuleName] -- Modules to exclude+ -> IO SummariseResult+++summariseModule hsc_env' home_unit old_summary_map is_boot (L loc wanted_mod) mb_pkg+ maybe_buf excl_mods+ | wanted_mod `elem` excl_mods+ = return NotThere+ | otherwise = find_it+ where+ -- Temporarily change the currently active home unit so all operations+ -- happen relative to it+ hsc_env = hscSetActiveHomeUnit home_unit hsc_env'+ dflags = hsc_dflags hsc_env++ find_it :: IO SummariseResult++ find_it = do+ found <- findImportedModule hsc_env wanted_mod mb_pkg+ case found of+ Found location mod+ | isJust (ml_hs_file location) -> do+ -- Home package+ fresult <- just_found location mod+ return $ case fresult of+ Left err -> FoundHomeWithError (moduleUnitId mod, err)+ Right ms -> FoundHome ms+ | VirtUnit iud <- moduleUnit mod+ , not (isHomeModule home_unit mod)+ -> return $ FoundInstantiation iud+ | otherwise -> return $ External (moduleUnitId mod)+ _ -> return NotThere+ -- Not found+ -- (If it is TRULY not found at all, we'll+ -- error when we actually try to compile)++ just_found location mod = do+ -- Adjust location to point to the hs-boot source file,+ -- hi file, object file, when is_boot says so+ let location' = case is_boot of+ IsBoot -> addBootSuffixLocn location+ NotBoot -> location+ src_fn = expectJust "summarise2" (ml_hs_file location')++ -- Check that it exists+ -- It might have been deleted since the Finder last found it+ maybe_h <- fileHashIfExists src_fn+ case maybe_h of+ Nothing -> return $ Left $ noHsFileErr loc src_fn+ Just h -> new_summary_cache_check location' mod src_fn h++ new_summary_cache_check loc mod src_fn h+ | Just old_summary <- Map.lookup src_fn old_summary_map =++ -- check the hash on the source file, and+ -- return the cached summary if it hasn't changed. If the+ -- file has changed then need to resummarise.+ case maybe_buf of+ Just (buf,_) ->+ checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc (fingerprintStringBuffer buf)+ Nothing ->+ checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc h+ | otherwise = new_summary loc mod src_fn h++ new_summary :: ModLocation+ -> Module+ -> FilePath+ -> Fingerprint+ -> IO (Either DriverMessages ModSummary)+ new_summary location mod src_fn src_hash+ = runExceptT $ do+ preimps@PreprocessedImports {..}+ -- Remember to set the active unit here, otherwise the wrong include paths are passed to CPP+ -- See multiHomeUnits_cpp2 test+ <- getPreprocessedImports (hscSetActiveUnitId (moduleUnitId mod) hsc_env) src_fn Nothing maybe_buf++ -- NB: Despite the fact that is_boot is a top-level parameter, we+ -- don't actually know coming into this function what the HscSource+ -- of the module in question is. This is because we may be processing+ -- this module because another module in the graph imported it: in this+ -- case, we know if it's a boot or not because of the {-# SOURCE #-}+ -- annotation, but we don't know if it's a signature or a regular+ -- module until we actually look it up on the filesystem.+ let hsc_src+ | is_boot == IsBoot = HsBootFile+ | isHaskellSigFilename src_fn = HsigFile+ | otherwise = HsSrcFile++ when (pi_mod_name /= wanted_mod) $+ throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc+ $ DriverFileModuleNameMismatch pi_mod_name wanted_mod++ let instantiations = homeUnitInstantiations home_unit+ when (hsc_src == HsigFile && isNothing (lookup pi_mod_name instantiations)) $+ throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc+ $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations++ liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary+ { nms_src_fn = src_fn+ , nms_src_hash = src_hash+ , nms_is_boot = is_boot+ , nms_hsc_src = hsc_src+ , nms_location = location+ , nms_mod = mod+ , nms_preimps = preimps+ }++-- | Convenience named arguments for 'makeNewModSummary' only used to make+-- code more readable, not exported.+data MakeNewModSummary+ = MakeNewModSummary+ { nms_src_fn :: FilePath+ , nms_src_hash :: Fingerprint+ , nms_is_boot :: IsBootInterface+ , nms_hsc_src :: HscSource+ , nms_location :: ModLocation+ , nms_mod :: Module+ , nms_preimps :: PreprocessedImports+ }++makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary+makeNewModSummary hsc_env MakeNewModSummary{..} = do+ let PreprocessedImports{..} = nms_preimps+ obj_timestamp <- modificationTimeIfExists (ml_obj_file nms_location)+ dyn_obj_timestamp <- modificationTimeIfExists (ml_dyn_obj_file nms_location)+ hi_timestamp <- modificationTimeIfExists (ml_hi_file nms_location)+ hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location)++ extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name+ (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_theimps++ return $+ ModSummary+ { ms_mod = nms_mod+ , ms_hsc_src = nms_hsc_src+ , ms_location = nms_location+ , ms_hspp_file = pi_hspp_fn+ , ms_hspp_opts = pi_local_dflags+ , ms_hspp_buf = Just pi_hspp_buf+ , ms_parsed_mod = Nothing+ , ms_srcimps = pi_srcimps+ , ms_ghc_prim_import = pi_ghc_prim_import+ , ms_textual_imps =+ ((,) NoPkgQual . noLoc <$> extra_sig_imports) +++ ((,) NoPkgQual . noLoc <$> implicit_sigs) +++ pi_theimps+ , ms_hs_hash = nms_src_hash+ , ms_iface_date = hi_timestamp+ , ms_hie_date = hie_timestamp+ , ms_obj_date = obj_timestamp+ , ms_dyn_obj_date = dyn_obj_timestamp+ }++data PreprocessedImports+ = PreprocessedImports+ { pi_local_dflags :: DynFlags+ , pi_srcimps :: [(PkgQual, Located ModuleName)]+ , pi_theimps :: [(PkgQual, Located ModuleName)]+ , pi_ghc_prim_import :: Bool+ , pi_hspp_fn :: FilePath+ , pi_hspp_buf :: StringBuffer+ , pi_mod_name_loc :: SrcSpan+ , pi_mod_name :: ModuleName+ }++-- Preprocess the source file and get its imports+-- The pi_local_dflags contains the OPTIONS pragmas+getPreprocessedImports+ :: HscEnv+ -> FilePath+ -> Maybe Phase+ -> Maybe (StringBuffer, UTCTime)+ -- ^ optional source code buffer and modification time+ -> ExceptT DriverMessages IO PreprocessedImports+getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do+ (pi_local_dflags, pi_hspp_fn)+ <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase+ pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn+ (pi_srcimps', pi_theimps', pi_ghc_prim_import, L pi_mod_name_loc pi_mod_name)+ <- ExceptT $ do+ let imp_prelude = xopt LangExt.ImplicitPrelude pi_local_dflags+ popts = initParserOpts pi_local_dflags+ mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn+ return (first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps)+ let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)+ let rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn))+ let pi_srcimps = rn_imps pi_srcimps'+ let pi_theimps = rn_imps pi_theimps'+ return PreprocessedImports {..}+++-----------------------------------------------------------------------------+-- Error messages+-----------------------------------------------------------------------------++-- Defer and group warning, error and fatal messages so they will not get lost+-- in the regular output.+withDeferredDiagnostics :: GhcMonad m => m a -> m a+withDeferredDiagnostics f = do+ dflags <- getDynFlags+ if not $ gopt Opt_DeferDiagnostics dflags+ then f+ else do+ warnings <- liftIO $ newIORef []+ errors <- liftIO $ newIORef []+ fatals <- liftIO $ newIORef []+ logger <- getLogger++ let deferDiagnostics _dflags !msgClass !srcSpan !msg = do+ let action = logMsg logger msgClass srcSpan msg+ case msgClass of+ MCDiagnostic SevWarning _reason+ -> atomicModifyIORef' warnings $ \i -> (action: i, ())+ MCDiagnostic SevError _reason+ -> atomicModifyIORef' errors $ \i -> (action: i, ())+ MCFatal+ -> atomicModifyIORef' fatals $ \i -> (action: i, ())+ _ -> action++ printDeferredDiagnostics = liftIO $+ forM_ [warnings, errors, fatals] $ \ref -> do+ -- This IORef can leak when the dflags leaks, so let us always+ -- reset the content.+ actions <- atomicModifyIORef' ref $ \i -> ([], i)+ sequence_ $ reverse actions++ MC.bracket+ (pushLogHookM (const deferDiagnostics))+ (\_ -> popLogHookM >> printDeferredDiagnostics)+ (\_ -> f)++noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope GhcMessage+-- ToDo: we don't have a proper line number for this error+noModError hsc_env loc wanted_mod err+ = mkPlainErrorMsgEnvelope loc $ GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $+ cannotFindModule hsc_env wanted_mod err++noHsFileErr :: SrcSpan -> String -> DriverMessages+noHsFileErr loc path+ = singleMessage $ mkPlainErrorMsgEnvelope loc (DriverFileNotFound path)++moduleNotFoundErr :: ModuleName -> DriverMessages+moduleNotFoundErr mod = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverModuleNotFound mod)++multiRootsErr :: [ModSummary] -> IO ()+multiRootsErr [] = panic "multiRootsErr"+multiRootsErr summs@(summ1:_)+ = throwOneError $ fmap GhcDriverMessage $+ mkPlainErrorMsgEnvelope noSrcSpan $ DriverDuplicatedModuleDeclaration mod files+ where+ mod = ms_mod summ1+ files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs++cyclicModuleErr :: [ModuleGraphNode] -> SDoc+-- From a strongly connected component we find+-- a single cycle to report+cyclicModuleErr mss+ = assert (not (null mss)) $+ case findCycle graph of+ Nothing -> text "Unexpected non-cycle" <+> ppr mss+ Just path0 -> vcat+ [ text "Module graph contains a cycle:"+ , nest 2 (show_path path0)]+ where+ graph :: [Node NodeKey ModuleGraphNode]+ graph =+ [ DigraphNode+ { node_payload = ms+ , node_key = mkNodeKey ms+ , node_dependencies = nodeDependencies False ms+ }+ | ms <- mss+ ]++ show_path :: [ModuleGraphNode] -> SDoc+ show_path [] = panic "show_path"+ show_path [m] = ppr_node m <+> text "imports itself"+ show_path (m1:m2:ms) = vcat ( nest 6 (ppr_node m1)+ : nest 6 (text "imports" <+> ppr_node m2)+ : go ms )+ where+ go [] = [text "which imports" <+> ppr_node m1]+ go (m:ms) = (text "which imports" <+> ppr_node m) : go ms++ ppr_node :: ModuleGraphNode -> SDoc+ ppr_node (ModuleNode _deps m) = text "module" <+> ppr_ms m+ ppr_node (InstantiationNode _uid u) = text "instantiated unit" <+> ppr u+ ppr_node (LinkNode uid _) = pprPanic "LinkNode should not be in a cycle" (ppr uid)++ ppr_ms :: ModSummary -> SDoc+ ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+>+ (parens (text (msHsFilePath ms)))+++cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m ()+cleanCurrentModuleTempFilesMaybe logger tmpfs dflags =+ unless (gopt Opt_KeepTmpFiles dflags) $+ liftIO $ cleanCurrentModuleTempFiles logger tmpfs+++addDepsToHscEnv :: [HomeModInfo] -> HscEnv -> HscEnv+addDepsToHscEnv deps hsc_env =+ hscUpdateHUG (\hug -> foldr addHomeModInfoToHug hug deps) hsc_env++setHPT :: HomePackageTable -> HscEnv -> HscEnv+setHPT deps hsc_env =+ hscUpdateHPT (const $ deps) hsc_env++setHUG :: HomeUnitGraph -> HscEnv -> HscEnv+setHUG deps hsc_env =+ hscUpdateHUG (const $ deps) hsc_env++-- | Wrap an action to catch and handle exceptions.+wrapAction :: HscEnv -> IO a -> IO (Maybe a)+wrapAction hsc_env k = do+ let lcl_logger = hsc_logger hsc_env+ lcl_dynflags = hsc_dflags hsc_env+ let logg err = printMessages lcl_logger (initDiagOpts lcl_dynflags) (srcErrorMessages err)+ -- MP: It is a bit strange how prettyPrintGhcErrors handles some errors but then we handle+ -- SourceError and ThreadKilled differently directly below. TODO: Refactor to use `catches`+ -- directly. MP should probably use safeTry here to not catch async exceptions but that will regress performance due to+ -- internally using forkIO.+ mres <- MC.try $ liftIO $ prettyPrintGhcErrors lcl_logger $ k+ case mres of+ Right res -> return $ Just res+ Left exc -> do+ case fromException exc of+ Just (err :: SourceError)+ -> logg err+ Nothing -> case fromException exc of+ -- ThreadKilled in particular needs to actually kill the thread.+ -- So rethrow that and the other async exceptions+ Just (err :: SomeAsyncException) -> throwIO err+ _ -> errorMsg lcl_logger (text (show exc))+ return Nothing++withParLog :: TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> IO b) -> IO b+withParLog lqq_var k cont = do+ let init_log = do+ -- Make a new log queue+ lq <- newLogQueue k+ -- Add it into the LogQueueQueue+ atomically $ initLogQueue lqq_var lq+ return lq+ finish_log lq = liftIO (finishLogQueue lq)+ MC.bracket init_log finish_log $ \lq -> cont (pushLogHook (const (parLogAction lq)))++withLoggerHsc :: Int -> MakeEnv -> (HscEnv -> IO a) -> IO a+withLoggerHsc k MakeEnv{withLogger, hsc_env} cont = do+ withLogger k $ \modifyLogger -> do+ let lcl_logger = modifyLogger (hsc_logger hsc_env)+ hsc_env' = hsc_env { hsc_logger = lcl_logger }+ -- Run continuation with modified logger+ cont hsc_env'+++executeInstantiationNode :: Int+ -> Int+ -> RunMakeM HomeUnitGraph+ -> UnitId+ -> InstantiatedUnit+ -> RunMakeM ()+executeInstantiationNode k n wait_deps uid iu = do+ -- Wait for the dependencies of this node+ deps <- wait_deps+ env <- ask+ -- Output of the logger is mediated by a central worker to+ -- avoid output interleaving+ msg <- asks env_messager+ lift $ MaybeT $ withLoggerHsc k env $ \hsc_env ->+ let lcl_hsc_env = setHUG deps hsc_env+ in wrapAction lcl_hsc_env $ do+ res <- upsweep_inst lcl_hsc_env msg k n uid iu+ cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env)+ return res+++executeCompileNode :: Int+ -> Int+ -> Maybe HomeModInfo+ -> RunMakeM HomeUnitGraph+ -> Maybe [ModuleName] -- List of modules we need to rehydrate before compiling+ -> ModSummary+ -> RunMakeM HomeModInfo+executeCompileNode k n !old_hmi wait_deps mrehydrate_mods mod = do+ me@MakeEnv{..} <- ask+ deps <- wait_deps+ -- Rehydrate any dependencies if this module had a boot file or is a signature file.+ lift $ MaybeT (withAbstractSem compile_sem $ withLoggerHsc k me $ \hsc_env -> do+ hydrated_hsc_env <- liftIO $ maybeRehydrateBefore (setHUG deps hsc_env) mod fixed_mrehydrate_mods+ let -- Use the cached DynFlags which includes OPTIONS_GHC pragmas+ lcl_dynflags = ms_hspp_opts mod+ let lcl_hsc_env =+ -- Localise the hsc_env to use the cached flags+ hscSetFlags lcl_dynflags $+ hydrated_hsc_env+ -- Compile the module, locking with a semphore to avoid too many modules+ -- being compiled at the same time leading to high memory usage.+ wrapAction lcl_hsc_env $ do+ res <- upsweep_mod lcl_hsc_env env_messager old_hmi mod k n+ cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) lcl_dynflags+ return res)++ where+ fixed_mrehydrate_mods =+ case ms_hsc_src mod of+ -- MP: It is probably a bit of a misimplementation in backpack that+ -- compiling a signature requires an knot_var for that unit.+ -- If you remove this then a lot of backpack tests fail.+ HsigFile -> Just []+ _ -> mrehydrate_mods++{- Rehydration, see Note [Rehydrating Modules] -}++rehydrate :: HscEnv -- ^ The HPT in this HscEnv needs rehydrating.+ -> [HomeModInfo] -- ^ These are the modules we want to rehydrate.+ -> IO HscEnv+rehydrate hsc_env hmis = do+ debugTraceMsg logger 2 $+ text "Re-hydrating loop: "+ new_mods <- fixIO $ \new_mods -> do+ let new_hpt = addListToHpt old_hpt new_mods+ let new_hsc_env = hscUpdateHPT (const new_hpt) hsc_env+ mds <- initIfaceCheck (text "rehydrate") new_hsc_env $+ mapM (typecheckIface . hm_iface) hmis+ let new_mods = [ (mn,hmi{ hm_details = details })+ | (hmi,details) <- zip hmis mds+ , let mn = moduleName (mi_module (hm_iface hmi)) ]+ return new_mods+ return $ setHPT (foldl' (\old (mn, hmi) -> addToHpt old mn hmi) old_hpt new_mods) hsc_env++ where+ logger = hsc_logger hsc_env+ to_delete = (map (moduleName . mi_module . hm_iface) hmis)+ -- Filter out old modules before tying the knot, otherwise we can end+ -- up with a thunk which keeps reference to the old HomeModInfo.+ !old_hpt = foldl' delFromHpt (hsc_HPT hsc_env) to_delete++-- If needed, then rehydrate the necessary modules with a suitable KnotVars for the+-- module currently being compiled.+maybeRehydrateBefore :: HscEnv -> ModSummary -> Maybe [ModuleName] -> IO HscEnv+maybeRehydrateBefore hsc_env _ Nothing = return hsc_env+maybeRehydrateBefore hsc_env mod (Just mns) = do+ knot_var <- initialise_knot_var hsc_env+ let hmis = map (expectJust "mr" . lookupHpt (hsc_HPT hsc_env)) mns+ rehydrate (hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv knot_var }) hmis++ where+ initialise_knot_var hsc_env = liftIO $+ let mod_name = homeModuleInstantiation (hsc_home_unit_maybe hsc_env) (ms_mod mod)+ in mkModuleEnv . (:[]) . (mod_name,) <$> newIORef emptyTypeEnv++maybeRehydrateAfter :: HomeModInfo+ -> HscEnv+ -> Maybe [ModuleName]+ -> IO (HomeUnitGraph, HomeModInfo)+maybeRehydrateAfter hmi new_hsc Nothing = return (hsc_HUG new_hsc, hmi)+maybeRehydrateAfter hmi new_hsc (Just mns) = do+ let new_hpt = hsc_HPT new_hsc+ hmis = map (expectJust "mrAfter" . lookupHpt new_hpt) mns+ new_mod_name = moduleName (mi_module (hm_iface hmi))+ hsc_env <- rehydrate (new_hsc { hsc_type_env_vars = emptyKnotVars }) (hmi : hmis)+ return (hsc_HUG hsc_env, expectJust "rehydrate" $ lookupHpt (hsc_HPT hsc_env) new_mod_name)++{-+Note [Hydrating Modules]+~~~~~~~~~~~~~~~~~~~~~~~~+There are at least 4 different representations of an interface file as described+by this diagram.++------------------------------+| On-disk M.hi |+------------------------------+ | ^+ | Read file | Write file+ V |+-------------------------------+| ByteString |+-------------------------------+ | ^+ | Binary.get | Binary.put+ V |+--------------------------------+| ModIface (an acyclic AST) |+--------------------------------+ | ^+ | hydrate | mkIfaceTc+ V |+---------------------------------+| ModDetails (lots of cycles) |+---------------------------------++The last step, converting a ModIface into a ModDetails is known as "hydration".++Hydration happens in three different places++* When an interface file is initially loaded from disk, it has to be hydrated.+* When a module is finished compiling, we hydrate the ModIface in order to generate+ the version of ModDetails which exists in memory (see Note [ModDetails and --make mode])+* When dealing with boot files and module loops (see Note [Rehydrating Modules])++Note [Rehydrating Modules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+If a module has a boot file then it is critical to rehydrate the modules on+the path between the two (see #20561).++Suppose we have ("R" for "recursive"):+```+R.hs-boot: module R where+ data T+ g :: T -> T++A.hs: module A( f, T, g ) where+ import {-# SOURCE #-} R+ data S = MkS T+ f :: T -> S = ...g...++R.hs: module R where+ import A+ data T = T1 | T2 S+ g = ...f...+```++## Why we need to rehydrate A's ModIface before compiling R.hs++After compiling A.hs we'll have a TypeEnv in which the Id for `f` has a type+type uses the AbstractTyCon T; and a TyCon for `S` that also mentions that same+AbstractTyCon. (Abstract because it came from R.hs-boot; we know nothing about+it.)++When compiling R.hs, we build a TyCon for `T`. But that TyCon mentions `S`, and+it currently has an AbstractTyCon for `T` inside it. But we want to build a+fully cyclic structure, in which `S` refers to `T` and `T` refers to `S`.++Solution: **rehydration**. *Before compiling `R.hs`*, rehydrate all the+ModIfaces below it that depend on R.hs-boot. To rehydrate a ModIface, call+`rehydrateIface` to convert it to a ModDetails. It's just a de-serialisation+step, no type inference, just lookups.++Now `S` will be bound to a thunk that, when forced, will "see" the final binding+for `T`; see [Tying the knot](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/tying-the-knot).+But note that this must be done *before* compiling R.hs.++## Why we need to rehydrate A's ModIface after compiling R.hs++When compiling R.hs, the knot-tying stuff above will ensure that `f`'s unfolding+mentions the `LocalId` for `g`. But when we finish R, we carefully ensure that+all those `LocalIds` are turned into completed `GlobalIds`, replete with+unfoldings etc. Alas, that will not apply to the occurrences of `g` in `f`'s+unfolding. And if we leave matters like that, they will stay that way, and *all*+subsequent modules that import A will see a crippled unfolding for `f`.++Solution: rehydrate both R and A's ModIface together, right after completing R.hs.++## Which modules to rehydrate++We only need rehydrate modules that are+* Below R.hs+* Above R.hs-boot++There might be many unrelated modules (in the home package) that don't need to be+rehydrated.++## Modules "above" the loop++This dark corner is the subject of #14092.++Suppose we add to our example+```+X.hs module X where+ import A+ data XT = MkX T+ fx = ...g...+```+If in `--make` we compile R.hs-boot, then A.hs, then X.hs, we'll get a `ModDetails` for `X` that has an AbstractTyCon for `T` in the the argument type of `MkX`. So:++* Either we should delay compiling X until after R has beeen compiled. (This is what we do)+* Or we should rehydrate X after compiling R -- because it transitively depends on R.hs-boot.++Ticket #20200 has exposed some issues to do with the knot-tying logic in GHC.Make, in `--make` mode.+#20200 has lots of issues, many of them now fixed;+this particular issue starts [here](https://gitlab.haskell.org/ghc/ghc/-/issues/20200#note_385758).++The wiki page [Tying the knot](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/tying-the-knot) is helpful.+Also closely related are+ * #14092+ * #14103++-}++executeLinkNode :: RunMakeM HomeUnitGraph -> (Int, Int) -> UnitId -> [NodeKey] -> RunMakeM ()+executeLinkNode wait_deps kn uid deps = do+ withCurrentUnit uid $ do+ MakeEnv{..} <- ask+ hug <- wait_deps+ let dflags = hsc_dflags hsc_env+ let hsc_env' = setHUG hug hsc_env+ msg' = (\messager -> \recomp -> messager hsc_env kn recomp (LinkNode deps uid)) <$> env_messager++ linkresult <- liftIO $ withAbstractSem compile_sem $ do+ link (ghcLink dflags)+ (hsc_logger hsc_env')+ (hsc_tmpfs hsc_env')+ (hsc_hooks hsc_env')+ dflags+ (hsc_unit_env hsc_env')+ True -- We already decided to link+ msg'+ (hsc_HPT hsc_env')+ case linkresult of+ Failed -> fail "Link Failed"+ Succeeded -> return ()+++-- | Wait for some dependencies to finish and then read from the given MVar.+wait_deps_hug :: MVar b -> [ResultVar (Maybe HomeModInfo)] -> ReaderT MakeEnv (MaybeT IO) b+wait_deps_hug hug_var deps = do+ _ <- wait_deps deps+ liftIO $ readMVar hug_var+++-- | Wait for dependencies to finish, and then return their results.+wait_deps :: [ResultVar (Maybe HomeModInfo)] -> RunMakeM [HomeModInfo]+wait_deps [] = return []+wait_deps (x:xs) = do+ res <- lift $ waitResult x+ case res of+ Nothing -> wait_deps xs+ Just hmi -> (hmi:) <$> wait_deps xs+++-- Executing the pipelines++-- | Start a thread which reads from the LogQueueQueue+++label_self :: String -> IO ()+label_self thread_name = do+ self_tid <- CC.myThreadId+ CC.labelThread self_tid thread_name+++runPipelines :: Int -> HscEnv -> Maybe Messager -> [MakeAction] -> IO ()+runPipelines n_job orig_hsc_env mHscMessager all_pipelines = do+ liftIO $ label_self "main --make thread"++ plugins_hsc_env <- initializePlugins orig_hsc_env Nothing+ case n_job of+ 1 -> runSeqPipelines plugins_hsc_env mHscMessager all_pipelines+ _n -> runParPipelines n_job plugins_hsc_env mHscMessager all_pipelines++runSeqPipelines :: HscEnv -> Maybe Messager -> [MakeAction] -> IO ()+runSeqPipelines plugin_hsc_env mHscMessager all_pipelines =+ let env = MakeEnv { hsc_env = plugin_hsc_env+ , withLogger = \_ k -> k id+ , compile_sem = AbstractSem (return ()) (return ())+ , env_messager = mHscMessager+ }+ in runAllPipelines 1 env all_pipelines+++-- | Build and run a pipeline+runParPipelines :: Int -- ^ How many capabilities to use+ -> HscEnv -- ^ The basic HscEnv which is augmented with specific info for each module+ -> Maybe Messager -- ^ Optional custom messager to use to report progress+ -> [MakeAction] -- ^ The build plan for all the module nodes+ -> IO ()+runParPipelines n_jobs plugin_hsc_env mHscMessager all_pipelines = do+++ -- A variable which we write to when an error has happened and we have to tell the+ -- logging thread to gracefully shut down.+ stopped_var <- newTVarIO False+ -- The queue of LogQueues which actions are able to write to. When an action starts it+ -- will add it's LogQueue into this queue.+ log_queue_queue_var <- newTVarIO newLogQueueQueue+ -- Thread which coordinates the printing of logs+ wait_log_thread <- logThread n_jobs (length all_pipelines) (hsc_logger plugin_hsc_env) stopped_var log_queue_queue_var -- Make the logger thread-safe, in case there is some output which isn't sent via the LogQueue.
compiler/GHC/Driver/MakeFile.hs view
@@ -16,7 +16,6 @@ import GHC.Prelude import qualified GHC-import GHC.Driver.Config.Finder import GHC.Driver.Monad import GHC.Driver.Session import GHC.Driver.Ppr@@ -36,7 +35,6 @@ import GHC.Iface.Load (cannotFindModule) -import GHC.Unit.Env import GHC.Unit.Module import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Graph@@ -216,14 +214,15 @@ throwGhcExceptionIO $ ProgramError $ showSDoc dflags $ GHC.cyclicModuleErr nodes -processDeps dflags _ _ _ _ (AcyclicSCC (InstantiationNode node))+processDeps dflags _ _ _ _ (AcyclicSCC (InstantiationNode _uid node)) = -- There shouldn't be any backpack instantiations; report them as well throwGhcExceptionIO $ ProgramError $ showSDoc dflags $ vcat [ text "Unexpected backpack instantiation in dependency graph while constructing Makefile:" , nest 2 $ ppr node ]+processDeps _dflags _ _ _ _ (AcyclicSCC (LinkNode {})) = return () -processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode (ExtendedModSummary node _)))+processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ node)) = do { let extra_suffixes = depSuffixes dflags include_pkg_deps = depIncludePkgDeps dflags src_file = msHsFilePath node@@ -291,14 +290,9 @@ -> Bool -- Record dependency on package modules -> IO (Maybe FilePath) -- Interface file findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do- let fc = hsc_FC hsc_env- let mhome_unit = ue_home_unit (hsc_unit_env hsc_env)- let units = hsc_units hsc_env- let dflags = hsc_dflags hsc_env- let fopts = initFinderOpts dflags -- Find the module; this will be fast because -- we've done it once during downsweep- r <- findImportedModule fc fopts units mhome_unit imp pkg+ r <- findImportedModule hsc_env imp pkg case r of Found loc _ -- Home package: just depend on the .hi or hi-boot file@@ -395,10 +389,9 @@ | otherwise = putMsg logger (hang (text "Module cycles found:") 2 pp_cycles) where- topoSort = filterToposortToModules $- GHC.topSortModuleGraph True module_graph Nothing+ topoSort = GHC.topSortModuleGraph True module_graph Nothing - cycles :: [[ModSummary]]+ cycles :: [[ModuleGraphNode]] cycles = [ c | CyclicSCC c <- topoSort ] @@ -406,14 +399,16 @@ $$ pprCycle c $$ blankLine | (n,c) <- [1..] `zip` cycles ] -pprCycle :: [ModSummary] -> SDoc+pprCycle :: [ModuleGraphNode] -> SDoc -- Print a cycle, but show only the imports within the cycle pprCycle summaries = pp_group (CyclicSCC summaries) where cycle_mods :: [ModuleName] -- The modules in this cycle- cycle_mods = map (moduleName . ms_mod) summaries+ cycle_mods = map (moduleName . ms_mod) [ms | ModuleNode _ ms <- summaries] - pp_group (AcyclicSCC ms) = pp_ms ms+ pp_group :: SCC ModuleGraphNode -> SDoc+ pp_group (AcyclicSCC (ModuleNode _ ms)) = pp_ms ms+ pp_group (AcyclicSCC _) = empty pp_group (CyclicSCC mss) = assert (not (null boot_only)) $ -- The boot-only list must be non-empty, else there would@@ -422,14 +417,15 @@ pp_ms loop_breaker $$ vcat (map pp_group groups) where (boot_only, others) = partition is_boot_only mss- is_boot_only ms = not (any in_group (map snd (ms_imps ms)))+ is_boot_only (ModuleNode _ ms) = not (any in_group (map snd (ms_imps ms)))+ is_boot_only _ = False in_group (L _ m) = m `elem` group_mods- group_mods = map (moduleName . ms_mod) mss+ group_mods = map (moduleName . ms_mod) [ms | ModuleNode _ ms <- mss] - loop_breaker = head boot_only+ loop_breaker = head ([ms | ModuleNode _ ms <- boot_only]) all_others = tail boot_only ++ others- groups = filterToposortToModules $- GHC.topSortModuleGraph True (mkModuleGraph $ extendModSummaryNoDeps <$> all_others) Nothing+ groups =+ GHC.topSortModuleGraph True (mkModuleGraph all_others) Nothing pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' ')) <+> (pp_imps empty (map snd (ms_imps summary)) $$
compiler/GHC/Driver/Pipeline.hs view
@@ -75,6 +75,7 @@ import GHC.Linker.ExtraObj import GHC.Linker.Static+import GHC.Linker.Static.Utils import GHC.Linker.Types import GHC.Utils.Outputable@@ -121,6 +122,7 @@ import qualified Data.Set as Set import Data.Time ( getCurrentTime )+import GHC.Iface.Recomp -- Simpler type synonym for actions in the pipeline monad type P m = TPipelineClass TPhase m@@ -301,10 +303,12 @@ = (Interpreter, gopt_set (dflags2 { backend = Interpreter }) Opt_ForceRecomp) | otherwise = (backend dflags, dflags2)- dflags = dflags3 { includePaths = addImplicitQuoteInclude old_paths [current_dir] }+ -- Note [Filepaths and Multiple Home Units]+ dflags = dflags3 { includePaths = offsetIncludePaths dflags3 $ addImplicitQuoteInclude old_paths [current_dir] } upd_summary = summary { ms_hspp_opts = dflags } hsc_env = hscSetFlags dflags hsc_env0 + -- --------------------------------------------------------------------------- -- Link --@@ -364,6 +368,7 @@ -> DynFlags -- ^ dynamic flags -> UnitEnv -- ^ unit environment -> Bool -- ^ attempt linking in batch mode?+ -> Maybe (RecompileRequired -> IO ()) -> HomePackageTable -- ^ what to link -> IO SuccessFlag @@ -374,13 +379,14 @@ -- exports main, i.e., we have good reason to believe that linking -- will succeed. -link ghcLink logger tmpfs hooks dflags unit_env batch_attempt_linking hpt =+link ghcLink logger tmpfs hooks dflags unit_env batch_attempt_linking mHscMessage hpt = case linkHook hooks of Nothing -> case ghcLink of NoLink -> return Succeeded- LinkBinary -> link' logger tmpfs dflags unit_env batch_attempt_linking hpt- LinkStaticLib -> link' logger tmpfs dflags unit_env batch_attempt_linking hpt- LinkDynLib -> link' logger tmpfs dflags unit_env batch_attempt_linking hpt+ LinkBinary -> normal_link+ LinkStaticLib -> normal_link+ LinkDynLib -> normal_link+ LinkMergedObj -> normal_link LinkInMemory | platformMisc_ghcWithInterpreter $ platformMisc dflags -> -- Not Linking...(demand linker will do the job)@@ -388,6 +394,8 @@ | otherwise -> panicBadLink LinkInMemory Just h -> h ghcLink dflags batch_attempt_linking hpt+ where+ normal_link = link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessage hpt panicBadLink :: GhcLink -> a@@ -399,10 +407,11 @@ -> DynFlags -- ^ dynamic flags -> UnitEnv -- ^ unit environment -> Bool -- ^ attempt linking in batch mode?+ -> Maybe (RecompileRequired -> IO ()) -> HomePackageTable -- ^ what to link -> IO SuccessFlag -link' logger tmpfs dflags unit_env batch_attempt_linking hpt+link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt | batch_attempt_linking = do let@@ -436,12 +445,12 @@ linking_needed <- linkingNeeded logger dflags unit_env staticLink linkables pkg_deps - if not (gopt Opt_ForceRecomp dflags) && not linking_needed+ forM_ mHscMessager $ \hscMessage -> hscMessage linking_needed+ if not (gopt Opt_ForceRecomp dflags) && (linking_needed == UpToDate) then do debugTraceMsg logger 2 (text exe_file <+> text "is up to date, linking not required.") return Succeeded else do - compilationProgressMsg logger (text "Linking " <> text exe_file <> text " ...") -- Don't showPass in Batch mode; doLink will do that for us. let link = case ghcLink dflags of@@ -462,7 +471,7 @@ return Succeeded -linkingNeeded :: Logger -> DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO Bool+linkingNeeded :: Logger -> DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO RecompileRequired linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do -- if the modification time on the executable is later than the -- modification times on all of the objects and libraries, then omit@@ -472,7 +481,7 @@ exe_file = exeFileName platform staticLink (outputFile_ dflags) e_exe_time <- tryIO $ getModificationUTCTime exe_file case e_exe_time of- Left _ -> return True+ Left _ -> return MustCompile Right t -> do -- first check object files and extra_ld_inputs let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]@@ -480,7 +489,7 @@ let (errs,extra_times) = partitionEithers e_extra_times let obj_times = map linkableTime linkables ++ extra_times if not (null errs) || any (t <) obj_times- then return True+ then return (RecompBecause ObjectsChanged) else do -- next, check libraries. XXX this only checks Haskell libraries,@@ -490,14 +499,19 @@ lib <- unitHsLibs (ghcNameVersion dflags) (ways dflags) c ] pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs- if any isNothing pkg_libfiles then return True else do+ if any isNothing pkg_libfiles then return (RecompBecause LibraryChanged) else do e_lib_times <- mapM (tryIO . getModificationUTCTime) (catMaybes pkg_libfiles) let (lib_errs,lib_times) = partitionEithers e_lib_times if not (null lib_errs) || any (t <) lib_times- then return True- else checkLinkInfo logger dflags unit_env pkg_deps exe_file+ then return (RecompBecause LibraryChanged)+ else do+ res <- checkLinkInfo logger dflags unit_env pkg_deps exe_file+ if res+ then return (RecompBecause FlagsChanged)+ else return UpToDate + findHSLib :: Platform -> Ways -> [String] -> String -> IO (Maybe FilePath) findHSLib platform ws dirs lib = do let batch_lib_file = if ws `hasNotWay` WayDyn@@ -559,6 +573,11 @@ LinkBinary -> linkBinary logger tmpfs dflags unit_env o_files [] LinkStaticLib -> linkStaticLib logger dflags unit_env o_files [] LinkDynLib -> linkDynLibCheck logger tmpfs dflags unit_env o_files []+ LinkMergedObj+ | Just out <- outputFile dflags+ , let objs = [ f | FileOption _ f <- ldInputs dflags ]+ -> joinObjectFiles hsc_env (o_files ++ objs) out+ | otherwise -> panic "Output path must be specified for LinkMergedObj" other -> panicBadLink other -----------------------------------------------------------------------------@@ -569,7 +588,7 @@ -- -- The object file created by compiling the _stub.c file is put into a -- temporary file, which will be later combined with the main .o file--- (see the MergeForeigns phase).+-- (see the MergeForeign phase). -- -- Moreover, we also let the user emit arbitrary C/C++/ObjC/ObjC++ files -- from TH, that are then compiled and linked to the module. This is@@ -763,7 +782,7 @@ Nothing -> return mlinkable Just o_fp -> do unlinked_time <- liftIO (liftIO getCurrentTime)- final_o <- use (T_MergeForeign pipe_env hsc_env (Just location) o_fp fos)+ final_o <- use (T_MergeForeign pipe_env hsc_env o_fp fos) let !linkable = LM unlinked_time (ms_mod mod_sum) [DotO final_o]@@ -810,7 +829,7 @@ mo_fn <- hscPostBackendPipeline pipe_env hsc_env HsSrcFile (backend (hsc_dflags hsc_env)) Nothing output_fn case mo_fn of Nothing -> panic "CMM pipeline - produced no .o file"- Just mo_fn -> use (T_MergeForeign pipe_env hsc_env Nothing mo_fn fos)+ Just mo_fn -> use (T_MergeForeign pipe_env hsc_env mo_fn fos) hscPostBackendPipeline :: P m => PipeEnv -> HscEnv -> HscSource -> Backend -> Maybe ModLocation -> FilePath -> m (Maybe FilePath) hscPostBackendPipeline _ _ HsBootFile _ _ _ = return Nothing
compiler/GHC/Driver/Pipeline/Execute.hs view
@@ -54,7 +54,6 @@ import System.FilePath import GHC.Utils.Misc import GHC.Utils.Outputable-import qualified Control.Exception as Exception import GHC.Unit.Info import GHC.Unit.State import GHC.Unit.Home@@ -83,7 +82,6 @@ import GHC.Driver.Env.KnotVars import GHC.Driver.Config.Finder import GHC.Rename.Names-import Data.Bifunctor (first) newtype HookedUse a = HookedUse { runHookedUse :: (Hooks, PhaseHook) -> IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch) via (ReaderT (Hooks, PhaseHook) IO)@@ -144,8 +142,8 @@ runLlvmLlcPhase pipe_env hsc_env input_fn runPhase (T_LlvmMangle pipe_env hsc_env input_fn) = runLlvmManglePhase pipe_env hsc_env input_fn-runPhase (T_MergeForeign pipe_env hsc_env location input_fn fos) =- runMergeForeign pipe_env hsc_env location input_fn fos+runPhase (T_MergeForeign pipe_env hsc_env input_fn fos) =+ runMergeForeign pipe_env hsc_env input_fn fos runLlvmManglePhase :: PipeEnv -> HscEnv -> FilePath -> IO [Char] runLlvmManglePhase pipe_env hsc_env input_fn = do@@ -155,8 +153,8 @@ llvmFixupAsm (targetPlatform dflags) input_fn output_fn return output_fn -runMergeForeign :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> [FilePath] -> IO FilePath-runMergeForeign _pipe_env hsc_env _location input_fn foreign_os = do+runMergeForeign :: PipeEnv -> HscEnv -> FilePath -> [FilePath] -> IO FilePath+runMergeForeign _pipe_env hsc_env input_fn foreign_os = do if null foreign_os then return input_fn else do@@ -167,10 +165,7 @@ (tmpDir (hsc_dflags hsc_env)) TFL_CurrentModule "o" copyFile input_fn new_o- let dflags = hsc_dflags hsc_env- logger = hsc_logger hsc_env- let tmpfs = hsc_tmpfs hsc_env- joinObjectFiles logger tmpfs dflags (new_o : foreign_os) input_fn+ joinObjectFiles hsc_env (new_o : foreign_os) input_fn return input_fn runLlvmLlcPhase :: PipeEnv -> HscEnv -> FilePath -> IO FilePath@@ -363,7 +358,7 @@ let platform = ue_platform unit_env let hcc = cc_phase `eqPhase` HCc - let cmdline_include_paths = includePaths dflags+ let cmdline_include_paths = offsetIncludePaths dflags (includePaths dflags) -- HC files have the dependent packages stamped into them pkgs <- if hcc then getHCFilePackages input_fn else return []@@ -384,10 +379,13 @@ -- (#16737). Doing it in this way is simpler and also enable the C -- compiler to perform preprocessing and parsing in a single pass, -- but it may introduce inconsistency if a different pgm_P is specified.- let more_preprocessor_opts = concat+ let opts = getOpts dflags opt_P+ aug_imports = augmentImports dflags opts++ more_preprocessor_opts = concat [ ["-Xpreprocessor", i] | not hcc- , i <- getOpts dflags opt_P+ , i <- aug_imports ] let gcc_extra_viac_flags = extraGccViaCFlags dflags@@ -642,7 +640,7 @@ let imp_prelude = xopt LangExt.ImplicitPrelude dflags popts = initParserOpts dflags rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)- rn_imps = fmap (first rn_pkg_qual)+ rn_imps = fmap (\(rpk, lmn@(L _ mn)) -> (rn_pkg_qual mn rpk, lmn)) eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff) case eimps of Left errs -> throwErrors (GhcPsMessage <$> errs)@@ -940,6 +938,12 @@ ArchRISCV64 -> "lp64d" _ -> "" ++-- Note [Filepaths and Multiple Home Units]+offsetIncludePaths :: DynFlags -> IncludeSpecs -> IncludeSpecs+offsetIncludePaths dflags (IncludeSpecs incs quotes impl) =+ let go = map (augmentByWorkingDirectory dflags)+ in IncludeSpecs (go incs) (go quotes) (go impl) -- ----------------------------------------------------------------------------- -- Running CPP @@ -949,12 +953,21 @@ doCpp :: Logger -> TmpFs -> DynFlags -> UnitEnv -> Bool -> FilePath -> FilePath -> IO () doCpp logger tmpfs dflags unit_env raw input_fn output_fn = do let hscpp_opts = picPOpts dflags- let cmdline_include_paths = includePaths dflags+ let cmdline_include_paths = offsetIncludePaths dflags (includePaths dflags) let unit_state = ue_units unit_env pkg_include_dirs <- mayThrowUnitErr (collectIncludeDirs <$> preloadUnitsInfo unit_env)+ -- MP: This is not quite right, the headers which are supposed to be installed in+ -- the package might not be the same as the provided include paths, but it's a close+ -- enough approximation for things to work. A proper solution would be to have to declare which paths should+ -- be propagated to dependent packages.+ let home_pkg_deps =+ [homeUnitEnv_dflags . ue_findHomeUnitEnv uid $ unit_env | uid <- ue_transitiveHomeDeps (ue_currentUnit unit_env) unit_env]+ dep_pkg_extra_inputs = [offsetIncludePaths fs (includePaths fs) | fs <- home_pkg_deps]+ let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []- (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)+ (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs+ ++ concatMap includePathsGlobal dep_pkg_extra_inputs) let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] (includePathsQuote cmdline_include_paths ++ includePathsQuoteImplicit cmdline_include_paths)@@ -1100,7 +1113,7 @@ We must enable bigobj output in a few places: - * When merging object files (GHC.Driver.Pipeline.joinObjectFiles)+ * When merging object files (GHC.Driver.Pipeline.Execute.joinObjectFiles) * When assembling (GHC.Driver.Pipeline.runPhase (RealPhase As ...)) @@ -1125,19 +1138,12 @@ -} -joinObjectFiles :: Logger -> TmpFs -> DynFlags -> [FilePath] -> FilePath -> IO ()-joinObjectFiles logger tmpfs dflags o_files output_fn = do+joinObjectFiles :: HscEnv -> [FilePath] -> FilePath -> IO ()+joinObjectFiles hsc_env o_files output_fn = do let toolSettings' = toolSettings dflags ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings'- osInfo = platformOS (targetPlatform dflags)- ld_r args = GHC.SysTools.runMergeObjects logger tmpfs dflags (- -- See Note [Produce big objects on Windows]- concat- [ [GHC.SysTools.Option "--oformat", GHC.SysTools.Option "pe-bigobj-x86-64"]- | OSMinGW32 == osInfo- , not $ target32Bit (targetPlatform dflags)- ]- ++ map GHC.SysTools.Option ld_build_id+ ld_r args = GHC.SysTools.runMergeObjects (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) (+ map GHC.SysTools.Option ld_build_id ++ [ GHC.SysTools.Option "-o", GHC.SysTools.FileOption "" output_fn ] ++ args)@@ -1146,7 +1152,7 @@ -- which we don't need and sometimes causes ld to emit a -- warning: ld_build_id | toolSettings_ldSupportsBuildId toolSettings' = ["--build-id=none"]- | otherwise = []+ | otherwise = [] if ldIsGnuLd then do@@ -1163,13 +1169,18 @@ GHC.SysTools.FileOption "" filelist] else ld_r (map (GHC.SysTools.FileOption "") o_files)+ where+ dflags = hsc_dflags hsc_env+ tmpfs = hsc_tmpfs hsc_env+ logger = hsc_logger hsc_env + ----------------------------------------------------------------------------- -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file getHCFilePackages :: FilePath -> IO [UnitId] getHCFilePackages filename =- Exception.bracket (openFile filename ReadMode) hClose $ \h -> do+ withFile filename ReadMode $ \h -> do l <- hGetLine h case l of '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->
compiler/GHC/Driver/Pipeline/LogQueue.hs view
@@ -5,13 +5,13 @@ , finishLogQueue , writeLogQueue , parLogAction- , printLogs , LogQueueQueue(..) , initLogQueue , allLogQueues , newLogQueueQueue- , dequeueLogQueueQueue++ , logThread ) where import GHC.Prelude@@ -22,6 +22,7 @@ import GHC.Utils.Logger import qualified Data.IntMap as IM import Control.Concurrent.STM+import Control.Monad -- LogQueue Abstraction @@ -99,3 +100,24 @@ Just ((k, v), lqq') | k == n -> Just (v, LogQueueQueue (n + 1) lqq') _ -> Nothing +logThread :: Int -> Int -> Logger -> TVar Bool -- Signal that no more new logs will be added, clear the queue and exit+ -> TVar LogQueueQueue -- Queue for logs+ -> IO (IO ())+logThread _ _ logger stopped lqq_var = do+ finished_var <- newEmptyMVar+ _ <- forkIO $ print_logs *> putMVar finished_var ()+ return (takeMVar finished_var)+ where+ finish = mapM (printLogs logger)++ print_logs = join $ atomically $ do+ lqq <- readTVar lqq_var+ case dequeueLogQueueQueue lqq of+ Just (lq, lqq') -> do+ writeTVar lqq_var lqq'+ return (printLogs logger lq *> print_logs)+ Nothing -> do+ -- No log to print, check if we are finished.+ stopped <- readTVar stopped+ if not stopped then retry+ else return (finish (allLogQueues lqq))
compiler/GHC/HsToCore.hs view
@@ -22,6 +22,7 @@ import GHC.Driver.Config import GHC.Driver.Env import GHC.Driver.Backend+import GHC.Driver.Plugins import GHC.Hs @@ -90,7 +91,6 @@ import Data.List (partition) import Data.IORef-import GHC.Driver.Plugins ( LoadedPlugin(..) ) {- ************************************************************************@@ -196,7 +196,7 @@ ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps ; let used_names = mkUsedNames tcg_env- pluginModules = map lpModule (hsc_plugins hsc_env)+ pluginModules = map lpModule (loadedPlugins (hsc_plugins hsc_env)) home_unit = hsc_home_unit hsc_env ; let deps = mkDependencies home_unit (tcg_mod tcg_env)
compiler/GHC/HsToCore/Binds.hs view
@@ -1271,7 +1271,7 @@ ; em <- getRep evm m ; mkTrFun <- dsLookupGlobalId mkTrFunName -- mkTrFun :: forall (m :: Multiplicity) r1 r2 (a :: TYPE r1) (b :: TYPE r2).- -- TypeRep m -> TypeRep a -> TypeRep b -> TypeRep (a # m -> b)+ -- TypeRep m -> TypeRep a -> TypeRep b -> TypeRep (a % m -> b) ; let r1 = getRuntimeRep t1 r2 = getRuntimeRep t2 ; return $ mkApps (mkTyApps (Var mkTrFun) [m, r1, r2, t1, t2])
compiler/GHC/HsToCore/Expr.hs view
@@ -1227,7 +1227,7 @@ otherwise. * For examples of how `withDict` is used in the `base` library, see `withSNat`- in GHC.TypeNats, as well as `withSChar` and `withSSymbol` n GHC.TypeLits.+ in GHC.TypeNats, as well as `withSChar` and `withSSymbol` in GHC.TypeLits. * The `r` is representation-polymorphic, to support things like `withTypeable` in `Data.Typeable.Internal`.
compiler/GHC/HsToCore/Match.hs view
@@ -1010,11 +1010,11 @@ -- Order is significant, match PgN after PgLit -- If the exponents are small check for value equality rather than syntactic equality -- This is implemented in the Eq instance for FractionalLit, we do this to avoid- -- computing the value of excessivly large rationals.+ -- computing the value of excessively large rationals. sameGroup (PgOverS s1) (PgOverS s2) = s1==s2 sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- See Note [Grouping overloaded literal patterns] sameGroup (PgCo t1) (PgCo t2) = t1 `eqType` t2- -- CoPats are in the same goup only if the type of the+ -- CoPats are in the same group only if the type of the -- enclosed pattern is the same. The patterns outside the CoPat -- always have the same type, so this boils down to saying that -- the two coercions are identical.
compiler/GHC/HsToCore/Usage.hs view
@@ -39,6 +39,7 @@ import GHC.Linker.Types import GHC.Linker.Loader ( getLoaderState ) import GHC.Types.SourceFile+import GHC.Unit.Finder {- Note [Module self-dependency] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -146,7 +147,7 @@ msg m = moduleNameString (moduleName m) ++ "[TH] changed" - fing mmsg fn = UsageFile fn <$> getFileHash fn <*> pure mmsg+ fing mmsg fn = UsageFile fn <$> lookupFileCache (hsc_FC hsc_env) fn <*> pure mmsg unlinkedToUsage m ul = case nameOfObject_maybe ul of@@ -154,7 +155,7 @@ Nothing -> do -- This should only happen for home package things but oneshot puts -- home package ifaces in the PIT.- let miface = lookupIfaceByModule (hsc_HPT hsc_env) pit m+ let miface = lookupIfaceByModule (hsc_HUG hsc_env) pit m case miface of Nothing -> pprPanic "mkObjectUsage" (ppr m) Just iface ->@@ -175,7 +176,7 @@ mk_mod_usage_info pit hsc_env this_mod direct_imports used_names = mapMaybe mkUsage usage_mods where- hpt = hsc_HPT hsc_env+ hpt = hsc_HUG hsc_env dflags = hsc_dflags hsc_env home_unit = hsc_home_unit hsc_env
compiler/GHC/Iface/Errors.hs view
@@ -17,7 +17,7 @@ import GHC.Platform.Ways import GHC.Utils.Panic.Plain import GHC.Driver.Session-import GHC.Driver.Env.Types+import GHC.Driver.Env import GHC.Driver.Errors.Types import GHC.Data.Maybe import GHC.Prelude@@ -213,7 +213,7 @@ = cannot_find <+> quotes (ppr mod_name) $$ more_info where- mhome_unit = ue_home_unit unit_env+ mhome_unit = ue_homeUnit unit_env more_info = case find_result of NoPackage pkg
compiler/GHC/Iface/Load.hs view
@@ -94,7 +94,6 @@ import GHC.Types.SourceFile import GHC.Types.SafeHaskell import GHC.Types.TypeEnv-import GHC.Types.Unique.FM import GHC.Types.Unique.DSet import GHC.Types.SrcLoc import GHC.Types.TyThing@@ -318,12 +317,7 @@ -- interface; it will call the Finder again, but the ModLocation will be -- cached from the first search. = do hsc_env <- getTopEnv- let fc = hsc_FC hsc_env- let dflags = hsc_dflags hsc_env- let fopts = initFinderOpts dflags- let units = hsc_units hsc_env- let mhome_unit = ue_home_unit (hsc_unit_env hsc_env)- res <- liftIO $ findImportedModule fc fopts units mhome_unit mod maybe_pkg+ res <- liftIO $ findImportedModule hsc_env mod maybe_pkg case res of Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot) -- TODO: Make sure this error message is good@@ -449,15 +443,15 @@ logger <- getLogger withTimingSilent logger (text "loading interface") (pure ()) $ do { -- Read the state- (eps,hpt) <- getEpsAndHpt+ (eps,hug) <- getEpsAndHug ; gbl_env <- getGblEnv ; liftIO $ trace_if logger (text "Considering whether to load" <+> ppr mod <+> ppr from) -- Check whether we have the interface already ; hsc_env <- getTopEnv- ; let mhome_unit = ue_home_unit (hsc_unit_env hsc_env)- ; case lookupIfaceByModule hpt (eps_PIT eps) mod of {+ ; let mhome_unit = ue_homeUnit (hsc_unit_env hsc_env)+ ; case lookupIfaceByModule hug (eps_PIT eps) mod of { Just iface -> return (Succeeded iface) ; -- Already loaded -- The (src_imp == mi_boot iface) test checks that the already-loaded@@ -497,7 +491,7 @@ in initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $ - dontLeakTheHPT $ do+ dontLeakTheHUG $ do -- Load the new ModIface into the External Package State -- Even home-package interfaces loaded by loadInterface@@ -515,6 +509,14 @@ -- If we do loadExport first the wrong info gets into the cache (unless we -- explicitly tag each export which seems a bit of a bore) + -- Crucial assertion that checks if you are trying to load a HPT module into the EPS.+ -- If you start loading HPT modules into the EPS then you get strange errors about+ -- overlapping instances.+ ; massertPpr+ ((isOneShot (ghcMode (hsc_dflags hsc_env)))+ || moduleUnitId mod `notElem` hsc_all_home_unit_ids hsc_env+ || mod == gHC_PRIM)+ (text "Attempting to load home package interface into the EPS" $$ ppr hug $$ doc_str $$ ppr mod $$ ppr (moduleUnitId mod)) ; ignore_prags <- goptM Opt_IgnoreInterfacePragmas ; new_eps_decls <- tcIfaceDecls ignore_prags (mi_decls iface) ; new_eps_insts <- mapM tcIfaceInst (mi_insts iface)@@ -575,7 +577,7 @@ ; -- invoke plugins with *full* interface, not final_iface, to ensure -- that plugins have access to declarations, etc.- res <- withPlugins hsc_env (\p -> interfaceLoadAction p) iface+ res <- withPlugins (hsc_plugins hsc_env) (\p -> interfaceLoadAction p) iface ; return (Succeeded res) }}}} @@ -630,8 +632,8 @@ -} -- Note [GHC Heap Invariants]-dontLeakTheHPT :: IfL a -> IfL a-dontLeakTheHPT thing_inside = do+dontLeakTheHUG :: IfL a -> IfL a+dontLeakTheHUG thing_inside = do env <- getTopEnv let inOneShot =@@ -656,10 +658,11 @@ keepFor20509 hmi | isHoleModule (mi_semantic_module (hm_iface hmi)) = True | otherwise = False+ pruneHomeUnitEnv hme = hme { homeUnitEnv_hpt = emptyHomePackageTable } !unit_env = old_unit_env- { ue_hpt = if anyHpt keepFor20509 (ue_hpt old_unit_env) then ue_hpt old_unit_env- else emptyHomePackageTable+ { ue_home_unit_graph = if anyHpt keepFor20509 (ue_hpt old_unit_env) then ue_home_unit_graph old_unit_env+ else unitEnv_map pruneHomeUnitEnv (ue_home_unit_graph old_unit_env) } in hsc_env { hsc_targets = panic "cleanTopEnv: hsc_targets"@@ -709,14 +712,8 @@ -> IO (MaybeErr SDoc (ModIface, FilePath)) computeInterface hsc_env doc_str hi_boot_file mod0 = do massert (not (isHoleModule mod0))- let name_cache = hsc_NC hsc_env- let fc = hsc_FC hsc_env- let mhome_unit = ue_home_unit (hsc_unit_env hsc_env)- let units = hsc_units hsc_env- let dflags = hsc_dflags hsc_env- let logger = hsc_logger hsc_env- let hooks = hsc_hooks hsc_env- let find_iface m = findAndReadIface logger name_cache fc hooks units mhome_unit dflags doc_str+ let mhome_unit = hsc_home_unit_maybe hsc_env+ let find_iface m = findAndReadIface hsc_env doc_str m mod0 hi_boot_file case getModuleInstantiation mod0 of (imod, Just indef)@@ -751,7 +748,7 @@ let insts = instUnitInsts (moduleUnit indef) liftIO $ trace_if logger (text "Considering whether to load" <+> ppr mod <+> text "to compute precise free module holes")- (eps, hpt) <- getEpsAndHpt+ (eps, hpt) <- getEpsAndHug case tryEpsAndHpt eps hpt `firstJust` tryDepsCache eps imod insts of Just r -> return (Succeeded r) Nothing -> readAndCache imod insts@@ -765,14 +762,7 @@ _otherwise -> Nothing readAndCache imod insts = do hsc_env <- getTopEnv- let nc = hsc_NC hsc_env- let fc = hsc_FC hsc_env- let units = hsc_units hsc_env- let dflags = hsc_dflags hsc_env- let logger = hsc_logger hsc_env- let hooks = hsc_hooks hsc_env- let mhome_unit = ue_home_unit (hsc_unit_env hsc_env)- mb_iface <- liftIO $ findAndReadIface logger nc fc hooks units mhome_unit dflags+ mb_iface <- liftIO $ findAndReadIface hsc_env (text "moduleFreeHolesPrecise" <+> doc_str) imod mod NotBoot case mb_iface of@@ -806,7 +796,7 @@ -- We never import boot modules from other packages! | otherwise- -> case lookupUFM (eps_is_boot eps) (moduleName mod) of+ -> case lookupInstalledModuleEnv (eps_is_boot eps) (toUnitId <$> mod) of Just (GWIB { gwib_isBoot = is_boot }) -> Succeeded is_boot Nothing ->@@ -864,13 +854,7 @@ -} findAndReadIface- :: Logger- -> NameCache- -> FinderCache- -> Hooks- -> UnitState- -> Maybe HomeUnit- -> DynFlags+ :: HscEnv -> SDoc -- ^ Reason for loading the iface (used for tracing) -> InstalledModule -- ^ The unique identifier of the on-disk module we're looking for -> Module -- ^ The *actual* module we're looking for. We use@@ -878,9 +862,19 @@ -- module we read out. -> IsBootInterface -- ^ Looking for .hi-boot or .hi file -> IO (MaybeErr SDoc (ModIface, FilePath))-findAndReadIface logger name_cache fc hooks unit_state mhome_unit dflags doc_str mod wanted_mod hi_boot_file = do+findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do+ let profile = targetProfile dflags+ unit_state = hsc_units hsc_env+ fc = hsc_FC hsc_env+ name_cache = hsc_NC hsc_env+ mhome_unit = hsc_home_unit_maybe hsc_env+ dflags = hsc_dflags hsc_env+ logger = hsc_logger hsc_env+ hooks = hsc_hooks hsc_env+ other_fopts = initFinderOpts . homeUnitEnv_dflags <$> (hsc_HUG hsc_env) + trace_if logger (sep [hsep [text "Reading", if hi_boot_file == IsBoot then text "[boot]"@@ -901,7 +895,7 @@ else do let fopts = initFinderOpts dflags -- Look for the file- mb_found <- liftIO (findExactModule fc fopts unit_state mhome_unit mod)+ mb_found <- liftIO (findExactModule fc fopts other_fopts unit_state mhome_unit mod) case mb_found of InstalledFound (addBootSuffixLocn_maybe hi_boot_file -> loc) mod -> do -- See Note [Home module load error]
compiler/GHC/Iface/Make.hs view
@@ -51,7 +51,7 @@ import GHC.Driver.Env import GHC.Driver.Backend import GHC.Driver.Session-import GHC.Driver.Plugins (LoadedPlugin(..))+import GHC.Driver.Plugins import GHC.Types.Id import GHC.Types.Fixity.Env@@ -197,7 +197,7 @@ } = do let used_names = mkUsedNames tc_result- let pluginModules = map lpModule (hsc_plugins hsc_env)+ let pluginModules = map lpModule (loadedPlugins (hsc_plugins hsc_env)) let home_unit = hsc_home_unit hsc_env let deps = mkDependencies home_unit (tcg_mod tc_result)
compiler/GHC/Iface/Recomp.hs view
@@ -19,7 +19,7 @@ import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Ppr-import GHC.Driver.Plugins ( PluginRecompile(..), PluginWithArgs(..), pluginRecompile', plugins )+import GHC.Driver.Plugins import GHC.Iface.Syntax import GHC.Iface.Recomp.Binary@@ -53,8 +53,6 @@ import GHC.Types.Unique import GHC.Types.Unique.Set import GHC.Types.Fixity.Env--import GHC.Unit.Env import GHC.Unit.External import GHC.Unit.Finder import GHC.Unit.State@@ -78,6 +76,7 @@ import GHC.List (uncons) import Data.Ord import Data.Containers.ListUtils+import Data.Bifunctor {- -----------------------------------------------@@ -121,6 +120,11 @@ -- to force recompilation; the String says what (one-line summary) deriving (Eq) +instance Outputable RecompileRequired where+ ppr UpToDate = text "UpToDate"+ ppr MustCompile = text "MustCompile"+ ppr (RecompBecause r) = text "RecompBecause" <+> ppr r+ instance Semigroup RecompileRequired where UpToDate <> r = r mc <> _ = mc@@ -141,8 +145,8 @@ | HieOutdated | SigsMergeChanged | ModuleChanged ModuleName- | ModuleRemoved ModuleName- | ModuleAdded ModuleName+ | ModuleRemoved (UnitId, ModuleName)+ | ModuleAdded (UnitId, ModuleName) | ModuleChangedRaw ModuleName | ModuleChangedIface ModuleName | FileChanged FilePath@@ -155,6 +159,8 @@ | MissingDynObjectFile | MissingDynHiFile | MismatchedDynHiFile+ | ObjectsChanged+ | LibraryChanged deriving (Eq) instance Outputable RecompReason where@@ -173,8 +179,8 @@ ModuleChanged m -> ppr m <+> text "changed" ModuleChangedRaw m -> ppr m <+> text "changed (raw)" ModuleChangedIface m -> ppr m <+> text "changed (interface)"- ModuleRemoved m -> ppr m <+> text "removed"- ModuleAdded m -> ppr m <+> text "added"+ ModuleRemoved (_uid, m) -> ppr m <+> text "removed"+ ModuleAdded (_uid, m) -> ppr m <+> text "added" FileChanged fp -> text fp <+> text "changed" CustomReason s -> text s FlagsChanged -> text "Flags changed"@@ -185,6 +191,8 @@ MissingDynObjectFile -> text "Missing dynamic object file" MissingDynHiFile -> text "Missing dynamic interface file" MismatchedDynHiFile -> text "Mismatched dynamic interface file"+ ObjectsChanged -> text "Objects changed"+ LibraryChanged -> text "Library changed" recompileRequired :: RecompileRequired -> Bool recompileRequired UpToDate = False@@ -333,7 +341,7 @@ ; if recompileRequired recomp then return (recomp, Nothing) else do { ; recomp <- checkDependencies hsc_env mod_summary iface ; if recompileRequired recomp then return (recomp, Just iface) else do {- ; recomp <- checkPlugins hsc_env iface+ ; recomp <- checkPlugins (hsc_plugins hsc_env) iface ; if recompileRequired recomp then return (recomp, Nothing) else do { @@ -362,30 +370,29 @@ -- | Check if any plugins are requesting recompilation-checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired-checkPlugins hsc_env iface = liftIO $ do- new_fingerprint <- fingerprintPlugins hsc_env+checkPlugins :: Plugins -> ModIface -> IfG RecompileRequired+checkPlugins plugins iface = liftIO $ do+ recomp <- recompPlugins plugins+ let new_fingerprint = fingerprintPluginRecompile recomp let old_fingerprint = mi_plugin_hash (mi_final_exts iface)- pr <- mconcat <$> mapM pluginRecompile' (plugins hsc_env)- return $- pluginRecompileToRecompileRequired old_fingerprint new_fingerprint pr+ return $ pluginRecompileToRecompileRequired old_fingerprint new_fingerprint recomp -fingerprintPlugins :: HscEnv -> IO Fingerprint-fingerprintPlugins hsc_env =- fingerprintPlugins' $ plugins hsc_env+recompPlugins :: Plugins -> IO PluginRecompile+recompPlugins plugins = mconcat <$> mapM pluginRecompile' (pluginsWithArgs plugins) -fingerprintPlugins' :: [PluginWithArgs] -> IO Fingerprint-fingerprintPlugins' plugins = do- res <- mconcat <$> mapM pluginRecompile' plugins- return $ case res of- NoForceRecompile -> fingerprintString "NoForceRecompile"- ForceRecompile -> fingerprintString "ForceRecompile"- -- is the chance of collision worth worrying about?- -- An alternative is to fingerprintFingerprints [fingerprintString- -- "maybeRecompile", fp]- (MaybeRecompile fp) -> fp+fingerprintPlugins :: Plugins -> IO Fingerprint+fingerprintPlugins plugins = fingerprintPluginRecompile <$> recompPlugins plugins +fingerprintPluginRecompile :: PluginRecompile -> Fingerprint+fingerprintPluginRecompile recomp = case recomp of+ NoForceRecompile -> fingerprintString "NoForceRecompile"+ ForceRecompile -> fingerprintString "ForceRecompile"+ -- is the chance of collision worth worrying about?+ -- An alternative is to fingerprintFingerprints [fingerprintString+ -- "maybeRecompile", fp]+ MaybeRecompile fp -> fp + pluginRecompileToRecompileRequired :: Fingerprint -> Fingerprint -> PluginRecompile -> RecompileRequired pluginRecompileToRecompileRequired old_fp new_fp pr@@ -527,7 +534,7 @@ checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired checkDependencies hsc_env summary iface = do- res_normal <- classify_import (findImportedModule fc fopts units mhome_unit) (ms_textual_imps summary ++ ms_srcimps summary)+ res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary) res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary) case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of Left recomp -> return recomp@@ -540,6 +547,11 @@ return (res1 `mappend` res2) where + classify_import :: (ModuleName -> t -> IO FindResult)+ -> [(t, GenLocated l ModuleName)]+ -> IfG+ [Either+ RecompileRequired (Either (UnitId, ModuleName) (String, UnitId))] classify_import find_import imports = liftIO $ traverse (\(mb_pkg, L _ mod) -> let reason = ModuleChanged mod@@ -549,9 +561,10 @@ fopts = initFinderOpts dflags logger = hsc_logger hsc_env fc = hsc_FC hsc_env- mhome_unit = ue_home_unit (hsc_unit_env hsc_env)+ mhome_unit = hsc_home_unit_maybe hsc_env+ all_home_units = hsc_all_home_unit_ids hsc_env units = hsc_units hsc_env- prev_dep_mods = map gwib_mod $ Set.toAscList $ dep_direct_mods (mi_deps iface)+ prev_dep_mods = map (second gwib_mod) $ Set.toAscList $ dep_direct_mods (mi_deps iface) prev_dep_pkgs = Set.toAscList (Set.union (dep_direct_pkgs (mi_deps iface)) (dep_plugin_pkgs (mi_deps iface))) bkpk_units = map (("Signature",) . instUnitInstanceOf . moduleUnit) (requirementMerges units (moduleName (mi_module iface)))@@ -561,23 +574,26 @@ -- GHC.Prim is very special and doesn't appear in ms_textual_imps but -- ghc-prim will appear in the package dependencies still. In order to not confuse -- the recompilation logic we need to not forget we imported GHC.Prim.- fake_ghc_prim_import = if notHomeUnitId mhome_unit primUnitId- then Right ("GHC.Prim", primUnitId)- else Left (mkModuleName "GHC.Prim")+ fake_ghc_prim_import = case mhome_unit of+ Just home_unit+ | homeUnitId home_unit == primUnitId+ -> Left (primUnitId, mkModuleName "GHC.Prim")+ _ -> Right ("GHC.Prim", primUnitId) classify _ (Found _ mod)- | Just home_unit <- mhome_unit- , isHomeUnit home_unit (moduleUnit mod) = Right (Left (moduleName mod))+ | (toUnitId $ moduleUnit mod) `elem` all_home_units = Right (Left ((toUnitId $ moduleUnit mod), moduleName mod)) | otherwise = Right (Right (moduleNameString (moduleName mod), toUnitId $ moduleUnit mod)) classify reason _ = Left (RecompBecause reason) + check_mods :: [(UnitId, ModuleName)] -> [(UnitId, ModuleName)] -> IO RecompileRequired check_mods [] [] = return UpToDate check_mods [] (old:_) = do -- This case can happen when a module is change from HPT to package import trace_hi_diffs logger $- text "module no longer " <> quotes (ppr old) <>+ text "module no longer" <+> quotes (ppr old) <+> text "in dependencies"+ return (RecompBecause (ModuleRemoved old)) check_mods (new:news) olds | Just (old, olds') <- uncons olds@@ -1164,7 +1180,7 @@ hpc_hash <- fingerprintHpcFlags dflags putNameLiterally - plugin_hash <- fingerprintPlugins hsc_env+ plugin_hash <- fingerprintPlugins (hsc_plugins hsc_env) -- the ABI hash depends on: -- - decls@@ -1256,21 +1272,14 @@ -- to recompile C and everything else. getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint] getOrphanHashes hsc_env mods = do- eps <- hscEPS hsc_env let- hpt = hsc_HPT hsc_env dflags = hsc_dflags hsc_env- pit = eps_PIT eps ctx = initSDocContext dflags defaultUserStyle- get_orph_hash mod =- case lookupIfaceByModule hpt pit mod of- Just iface -> return (mi_orphan_hash (mi_final_exts iface))- Nothing -> do -- similar to 'mkHashFun'- iface <- initIfaceLoad hsc_env . withException ctx+ get_orph_hash mod = do+ iface <- initIfaceLoad hsc_env . withException ctx $ loadInterface (text "getOrphanHashes") mod ImportBySystem- return (mi_orphan_hash (mi_final_exts iface))+ return (mi_orphan_hash (mi_final_exts iface)) - -- mapM get_orph_hash mods @@ -1547,7 +1556,7 @@ where home_unit = hsc_home_unit hsc_env dflags = hsc_dflags hsc_env- hpt = hsc_HPT hsc_env+ hpt = hsc_HUG hsc_env pit = eps_PIT eps ctx = initSDocContext dflags defaultUserStyle occ = nameOccName name
compiler/GHC/Iface/Recomp/Flags.hs view
@@ -37,7 +37,7 @@ fingerprintDynFlags hsc_env this_mod nameio = let dflags@DynFlags{..} = hsc_dflags hsc_env- mainis = if mainModIs hsc_env == this_mod then Just mainFunIs else Nothing+ mainis = if mainModIs (hsc_HUE hsc_env) == this_mod then Just mainFunIs else Nothing -- see #5878 -- pkgopts = (homeUnit home_unit, sort $ packageFlags dflags) safeHs = setSafeMode safeHaskell
compiler/GHC/Iface/Tidy.hs view
@@ -1338,106 +1338,3 @@ -- it to the top level. So it seems more robust just to -- fix it here. arity = exprArity orig_rhs--{--************************************************************************-* *- Old, dead, type-trimming code-* *-************************************************************************--We used to try to "trim off" the constructors of data types that are-not exported, to reduce the size of interface files, at least without--O. But that is not always possible: see the old Note [When we can't-trim types] below for exceptions.--Then (#7445) I realised that the TH problem arises for any data type-that we have deriving( Data ), because we can invoke- Language.Haskell.TH.Quote.dataToExpQ-to get a TH Exp representation of a value built from that data type.-You don't even need {-# LANGUAGE TemplateHaskell #-}.--At this point I give up. The pain of trimming constructors just-doesn't seem worth the gain. So I've dumped all the code, and am just-leaving it here at the end of the module in case something like this-is ever resurrected.---Note [When we can't trim types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The basic idea of type trimming is to export algebraic data types-abstractly (without their data constructors) when compiling without--O, unless of course they are explicitly exported by the user.--We always export synonyms, because they can be mentioned in the type-of an exported Id. We could do a full dependency analysis starting-from the explicit exports, but that's quite painful, and not done for-now.--But there are some times we can't do that, indicated by the 'no_trim_types' flag.--First, Template Haskell. Consider (#2386) this- module M(T, makeOne) where- data T = Yay String- makeOne = [| Yay "Yep" |]-Notice that T is exported abstractly, but makeOne effectively exports it too!-A module that splices in $(makeOne) will then look for a declaration of Yay,-so it'd better be there. Hence, brutally but simply, we switch off type-constructor trimming if TH is enabled in this module.--Second, data kinds. Consider (#5912)- {-# LANGUAGE DataKinds #-}- module M() where- data UnaryTypeC a = UnaryDataC a- type Bug = 'UnaryDataC-We always export synonyms, so Bug is exposed, and that means that-UnaryTypeC must be too, even though it's not explicitly exported. In-effect, DataKinds means that we'd need to do a full dependency analysis-to see what data constructors are mentioned. But we don't do that yet.--In these two cases we just switch off type trimming altogether.--mustExposeTyCon :: Bool -- Type-trimming flag- -> NameSet -- Exports- -> TyCon -- The tycon- -> Bool -- Can its rep be hidden?--- We are compiling without -O, and thus trying to write as little as--- possible into the interface file. But we must expose the details of--- any data types whose constructors or fields are exported-mustExposeTyCon no_trim_types exports tc- | no_trim_types -- See Note [When we can't trim types]- = True-- | not (isAlgTyCon tc) -- Always expose synonyms (otherwise we'd have to- -- figure out whether it was mentioned in the type- -- of any other exported thing)- = True-- | isEnumerationTyCon tc -- For an enumeration, exposing the constructors- = True -- won't lead to the need for further exposure-- | isFamilyTyCon tc -- Open type family- = True-- -- Below here we just have data/newtype decls or family instances-- | null data_cons -- Ditto if there are no data constructors- = True -- (NB: empty data types do not count as enumerations- -- see Note [Enumeration types] in GHC.Core.TyCon-- | any exported_con data_cons -- Expose rep if any datacon or field is exported- = True-- | isNewTyCon tc && isFFITy (snd (newTyConRhs tc))- = True -- Expose the rep for newtypes if the rep is an FFI type.- -- For a very annoying reason. 'Foreign import' is meant to- -- be able to look through newtypes transparently, but it- -- can only do that if it can "see" the newtype representation-- | otherwise- = False- where- data_cons = tyConDataCons tc- exported_con con = any (`elemNameSet` exports)- (dataConName con : dataConFieldLabels con)--}
compiler/GHC/IfaceToCore.hs view
@@ -539,8 +539,8 @@ -- (it's been replaced by the mother module) so we can't check it. -- And that's fine, because if M's ModInfo is in the HPT, then -- it's been compiled once, and we don't need to check the boot iface- then do { hpt <- getHpt- ; case lookupHpt hpt (moduleName mod) of+ then do { (_, hug) <- getEpsAndHug+ ; case lookupHugByModule mod hug of Just info | mi_boot (hm_iface info) == IsBoot -> mkSelfBootInfo (hm_iface info) (hm_details info) _ -> return NoSelfBoot }@@ -551,14 +551,7 @@ -- to check consistency against, rather than just when we notice -- that an hi-boot is necessary due to a circular import. { hsc_env <- getTopEnv- ; let nc = hsc_NC hsc_env- ; let fc = hsc_FC hsc_env- ; let mhome_unit = ue_home_unit (hsc_unit_env hsc_env)- ; let units = hsc_units hsc_env- ; let dflags = hsc_dflags hsc_env- ; let logger = hsc_logger hsc_env- ; let hooks = hsc_hooks hsc_env- ; read_result <- liftIO $ findAndReadIface logger nc fc hooks units mhome_unit dflags+ ; read_result <- liftIO $ findAndReadIface hsc_env need (fst (getModuleInstantiation mod)) mod IsBoot -- Hi-boot file @@ -575,7 +568,7 @@ -- a SOURCE import) or that our hi-boot file has mysteriously -- disappeared. do { eps <- getEps- ; case lookupUFM (eps_is_boot eps) (moduleName mod) of+ ; case lookupInstalledModuleEnv (eps_is_boot eps) (toUnitId <$> mod) of -- The typical case Nothing -> return NoSelfBoot -- error cases
compiler/GHC/Linker/Loader.hs view
@@ -54,7 +54,6 @@ import GHC.Runtime.Interpreter import GHCi.RemoteTypes -import GHC.Iface.Load import GHC.ByteCode.Linker import GHC.ByteCode.Asm@@ -72,7 +71,6 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Constants (isWindowsHost, isDarwinHost)-import GHC.Utils.Misc import GHC.Utils.Error import GHC.Utils.Logger import GHC.Utils.TmpFs@@ -82,7 +80,6 @@ import GHC.Unit.Module import GHC.Unit.Module.ModIface import GHC.Unit.Module.Deps-import GHC.Unit.Home import GHC.Unit.Home.ModInfo import GHC.Unit.State as Packages @@ -119,6 +116,12 @@ import qualified Data.Map as M import Data.Either (partitionEithers) +import GHC.Unit.Module.Graph+import GHC.Types.SourceFile+import GHC.Utils.Misc+import GHC.Iface.Load+import GHC.Unit.Home+ uninitialised :: a uninitialised = panic "Loader not initialised" @@ -210,7 +213,6 @@ -> IO (LoaderState, SuccessFlag) loadDependencies interp hsc_env pls span needed_mods = do -- initLoaderState (hsc_dflags hsc_env) dl- let hpt = hsc_HPT hsc_env let dflags = hsc_dflags hsc_env -- The interpreter and dynamic linker can only handle object code built -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.@@ -219,11 +221,11 @@ maybe_normal_osuf <- checkNonStdWay dflags interp (fst span) -- Find what packages and linkables are required- (lnks, all_lnks, pkgs) <- getLinkDeps hsc_env hpt pls+ (lnks, all_lnks, pkgs) <- getLinkDeps hsc_env pls maybe_normal_osuf (fst span) needed_mods let pls1 =- case (snd span) of+ case snd span of Just mn -> pls { module_deps = M.insertWith (++) mn all_lnks (module_deps pls) } Nothing -> pls @@ -310,8 +312,9 @@ -- (a) initialise the C dynamic linker initObjLinker interp + -- (b) Load packages from the command-line (Note [preload packages])- pls <- loadPackages' interp hsc_env (preloadUnits (hsc_units hsc_env)) pls0+ pls <- unitEnv_foldWithKey (\k u env -> k >>= \pls' -> loadPackages' interp (hscSetActiveUnitId u hsc_env) (preloadUnits (homeUnitEnv_units env)) pls') (return pls0) (hsc_HUG hsc_env) -- steps (c), (d) and (e) loadCmdLineLibs' interp hsc_env pls@@ -323,13 +326,33 @@ modifyLoaderState_ interp $ \pls -> loadCmdLineLibs' interp hsc_env pls -loadCmdLineLibs'++loadCmdLineLibs' :: Interp -> HscEnv -> LoaderState -> IO LoaderState+loadCmdLineLibs' interp hsc_env pls = snd <$>+ foldM+ (\(done', pls') cur_uid -> load done' cur_uid pls')+ (Set.empty, pls)+ (hsc_all_home_unit_ids hsc_env)++ where+ load :: Set.Set UnitId -> UnitId -> LoaderState -> IO (Set.Set UnitId, LoaderState)+ load done uid pls | uid `Set.member` done = return (done, pls)+ load done uid pls = do+ let hsc' = hscSetActiveUnitId uid hsc_env+ -- Load potential dependencies first+ (done', pls') <- foldM (\(done', pls') uid -> load done' uid pls') (done, pls)+ (homeUnitDepends (hsc_units hsc'))+ pls'' <- loadCmdLineLibs'' interp hsc' pls'+ return $ (Set.insert uid done', pls'')++loadCmdLineLibs'' :: Interp -> HscEnv -> LoaderState -> IO LoaderState-loadCmdLineLibs' interp hsc_env pls =+loadCmdLineLibs'' interp hsc_env pls = do+ let dflags@(DynFlags { ldInputs = cmdline_ld_inputs , libraryPaths = lib_paths_base}) = hsc_dflags hsc_env@@ -661,7 +684,7 @@ Prof -> "with -prof" Dyn -> "with -dynamic" -getLinkDeps :: HscEnv -> HomePackageTable+getLinkDeps :: HscEnv -> LoaderState -> Maybe FilePath -- replace object suffixes? -> SrcSpan -- for error messages@@ -669,13 +692,21 @@ -> IO ([Linkable], [Linkable], [UnitId]) -- ... then link these first -- Fails with an IO exception if it can't find enough files -getLinkDeps hsc_env hpt pls replace_osuf span mods+getLinkDeps hsc_env pls replace_osuf span mods -- Find all the packages and linkables that a set of modules depends on = do { -- 1. Find the dependent home-pkg-modules/packages from each iface -- (omitting modules from the interactive package, which is already linked)- ; (mods_s, pkgs_s) <- follow_deps (filterOut isInteractiveModule mods)- emptyUniqDSet emptyUniqDSet;+ ; (mods_s, pkgs_s) <-+ -- Why two code paths here? There is a significant amount of repeated work+ -- performed calculating transitive dependencies+ -- if --make uses the oneShot code path (see MultiLayerModulesTH_* tests)+ if isOneShot (ghcMode dflags)+ then follow_deps (filterOut isInteractiveModule mods)+ emptyUniqDSet emptyUniqDSet;+ else do+ (pkgs, mmods) <- unzip <$> mapM get_mod_info all_home_mods+ return (catMaybes mmods, Set.toList (Set.unions (init_pkg_set : pkgs))) ; let -- 2. Exclude ones already linked@@ -683,11 +714,11 @@ (mods_needed, mods_got) = partitionEithers (map split_mods mods_s) pkgs_needed = pkgs_s `minusList` pkgs_loaded pls - split_mods mod_name =- let is_linked = find ((== mod_name) . (moduleName . linkableModule)) (objs_loaded pls ++ bcos_loaded pls)+ split_mods mod =+ let is_linked = find ((== mod) . (linkableModule)) (objs_loaded pls ++ bcos_loaded pls) in case is_linked of Just linkable -> Right linkable- Nothing -> Left mod_name+ Nothing -> Left mod -- 3. For each dependent module, find its linkable -- This will either be in the HPT or (in the case of one-shot@@ -698,16 +729,62 @@ ; return (lnks_needed, mods_got ++ lnks_needed, pkgs_needed) } where dflags = hsc_dflags hsc_env+ mod_graph = hsc_mod_graph hsc_env - -- The ModIface contains the transitive closure of the module dependencies- -- within the current package, *except* for boot modules: if we encounter- -- a boot module, we have to find its real interface and discover the- -- dependencies of that. Hence we need to traverse the dependency- -- tree recursively. See bug #936, testcase ghci/prog007.+ -- This code is used in `--make` mode to calculate the home package and unit dependencies+ -- for a set of modules.+ --+ -- It is significantly more efficient to use the shared transitive dependency+ -- calculation than to compute the transitive dependency set in the same manner as oneShot mode.++ -- It is also a matter of correctness to use the module graph so that dependencies between home units+ -- is resolved correctly.+ make_deps_loop :: (Set.Set UnitId, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (Set.Set UnitId, Set.Set NodeKey)+ make_deps_loop found [] = found+ make_deps_loop found@(found_units, found_mods) (nk:nexts)+ | NodeKey_Module nk `Set.member` found_mods = make_deps_loop found nexts+ | otherwise =+ case M.lookup (NodeKey_Module nk) (mgTransDeps mod_graph) of+ Just trans_deps ->+ let deps = Set.insert (NodeKey_Module nk) trans_deps+ -- See #936 and the ghci.prog007 test for why we have to continue traversing through+ -- boot modules.+ todo_boot_mods = [ModNodeKeyWithUid (GWIB mn NotBoot) uid | NodeKey_Module (ModNodeKeyWithUid (GWIB mn IsBoot) uid) <- Set.toList trans_deps]+ in make_deps_loop (found_units, deps `Set.union` found_mods) (todo_boot_mods ++ nexts)+ Nothing ->+ let (ModNodeKeyWithUid _ uid) = nk+ in make_deps_loop (uid `Set.insert` found_units, found_mods) nexts++ mkNk m = ModNodeKeyWithUid (GWIB (moduleName m) NotBoot) (moduleUnitId m)+ (init_pkg_set, all_deps) = make_deps_loop (Set.empty, Set.empty) $ map mkNk (filterOut isInteractiveModule mods)++ all_home_mods = [with_uid | NodeKey_Module with_uid <- Set.toList all_deps]++ get_mod_info (ModNodeKeyWithUid gwib uid) =+ case lookupHug (hsc_HUG hsc_env) uid (gwib_mod gwib) of+ Just hmi ->+ let iface = (hm_iface hmi)+ mmod = case mi_hsc_src iface of+ HsBootFile -> link_boot_mod_error (mi_module iface)+ _ -> return $ Just (mi_module iface)++ in (dep_direct_pkgs (mi_deps iface),) <$> mmod+ Nothing ->+ let err = text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid+ in throwGhcExceptionIO (ProgramError (showSDoc dflags err))+++ -- This code is used in one-shot mode to traverse downwards through the HPT+ -- to find all link dependencies.+ -- The ModIface contains the transitive closure of the module dependencies+ -- within the current package, *except* for boot modules: if we encounter+ -- a boot module, we have to find its real interface and discover the+ -- dependencies of that. Hence we need to traverse the dependency+ -- tree recursively. See bug #936, testcase ghci/prog007. follow_deps :: [Module] -- modules to follow- -> UniqDSet ModuleName -- accum. module dependencies+ -> UniqDSet Module -- accum. module dependencies -> UniqDSet UnitId -- accum. package dependencies- -> IO ([ModuleName], [UnitId]) -- result+ -> IO ([Module], [UnitId]) -- result follow_deps [] acc_mods acc_pkgs = return (uniqDSetToList acc_mods, uniqDSetToList acc_pkgs) follow_deps (mod:mods) acc_mods acc_pkgs@@ -727,23 +804,28 @@ pkg_deps = dep_direct_pkgs deps (boot_deps, mod_deps) = flip partitionWith (Set.toList (dep_direct_mods deps)) $ \case- GWIB m IsBoot -> Left m- GWIB m NotBoot -> Right m+ (_, GWIB m IsBoot) -> Left m+ (_, GWIB m NotBoot) -> Right m - mod_deps' = filter (not . (`elementOfUniqDSet` acc_mods)) (boot_deps ++ mod_deps)- acc_mods' = addListToUniqDSet acc_mods (moduleName mod : mod_deps)+ mod_deps' = case hsc_home_unit_maybe hsc_env of+ Nothing -> []+ Just home_unit -> filter (not . (`elementOfUniqDSet` acc_mods)) (map (mkHomeModule home_unit) $ (boot_deps ++ mod_deps))+ acc_mods' = case hsc_home_unit_maybe hsc_env of+ Nothing -> acc_mods+ Just home_unit -> addListToUniqDSet acc_mods (mod : map (mkHomeModule home_unit) mod_deps) acc_pkgs' = addListToUniqDSet acc_pkgs (Set.toList pkg_deps)- --- case ue_home_unit (hsc_unit_env hsc_env) of- Just home_unit- | isHomeUnit home_unit pkg- -> follow_deps (map (mkHomeModule home_unit) mod_deps' ++ mods) acc_mods' acc_pkgs'- _ -> follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg))++ case hsc_home_unit_maybe hsc_env of+ Just home_unit | isHomeUnit home_unit pkg -> follow_deps (mod_deps' ++ mods)+ acc_mods' acc_pkgs'+ _ -> follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg)) where- msg = text "need to link module" <+> ppr mod <+>+ msg = text "need to link module" <+> ppr mod <+> text "due to use of Template Haskell" ++ link_boot_mod_error :: Module -> IO a link_boot_mod_error mod = throwGhcExceptionIO (ProgramError (showSDoc dflags ( text "module" <+> ppr mod <+>@@ -759,22 +841,23 @@ -- This one is a build-system bug - get_linkable osuf mod_name -- A home-package module- | Just mod_info <- lookupHpt hpt mod_name+ get_linkable osuf mod -- A home-package module+ | Just mod_info <- lookupHugByModule mod (hsc_HUG hsc_env) = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info)) | otherwise = do -- It's not in the HPT because we are in one shot mode, -- so use the Finder to get a ModLocation...- case ue_home_unit (hsc_unit_env hsc_env) of- Nothing -> no_obj mod_name+ case hsc_home_unit_maybe hsc_env of+ Nothing -> no_obj mod Just home_unit -> do+ let fc = hsc_FC hsc_env let dflags = hsc_dflags hsc_env let fopts = initFinderOpts dflags- mb_stuff <- findHomeModule fc fopts home_unit mod_name+ mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod) case mb_stuff of Found loc mod -> found loc mod- _ -> no_obj mod_name+ _ -> no_obj (moduleName mod) where found loc mod = do { -- ...and then find the linkable for it
compiler/GHC/Linker/Static.hs view
@@ -2,7 +2,6 @@ ( linkBinary , linkBinary' , linkStaticLib- , exeFileName ) where @@ -29,6 +28,7 @@ import GHC.Linker.Dynamic import GHC.Linker.ExtraObj import GHC.Linker.Windows+import GHC.Linker.Static.Utils import GHC.Driver.Session @@ -306,30 +306,3 @@ -- run ranlib over the archive. write*Ar does *not* create the symbol index. runRanlib logger dflags [GHC.SysTools.FileOption "" output_fn]------ | Compute the output file name of a program.------ StaticLink boolean is used to indicate if the program is actually a static library--- (e.g., on iOS).------ Use the provided filename (if any), otherwise use "main.exe" (Windows),--- "a.out (otherwise without StaticLink set), "liba.a". In every case, add the--- extension if it is missing.-exeFileName :: Platform -> Bool -> Maybe FilePath -> FilePath-exeFileName platform staticLink output_fn- | Just s <- output_fn =- case platformOS platform of- OSMinGW32 -> s <?.> "exe"- _ -> if staticLink- then s <?.> "a"- else s- | otherwise =- if platformOS platform == OSMinGW32- then "main.exe"- else if staticLink- then "liba.a"- else "a.out"- where s <?.> ext | null (takeExtension s) = s <.> ext- | otherwise = s
compiler/GHC/Llvm.hs view
@@ -10,9 +10,6 @@ -- module GHC.Llvm (- LlvmOpts (..),- initLlvmOpts,- -- * Modules, Functions and Blocks LlvmModule(..),
compiler/GHC/Llvm/Ppr.hs view
@@ -39,6 +39,8 @@ import Data.Int import Data.List ( intersperse ) import GHC.Utils.Outputable++import GHC.CmmToLlvm.Config import GHC.Utils.Panic import GHC.Types.Unique @@ -47,7 +49,7 @@ -------------------------------------------------------------------------------- -- | Print out a whole LLVM module.-ppLlvmModule :: LlvmOpts -> LlvmModule -> SDoc+ppLlvmModule :: LlvmCgConfig -> LlvmModule -> SDoc ppLlvmModule opts (LlvmModule comments aliases meta globals decls funcs) = ppLlvmComments comments $+$ newLine $+$ ppLlvmAliases aliases $+$ newLine@@ -66,11 +68,11 @@ -- | Print out a list of global mutable variable definitions-ppLlvmGlobals :: LlvmOpts -> [LMGlobal] -> SDoc+ppLlvmGlobals :: LlvmCgConfig -> [LMGlobal] -> SDoc ppLlvmGlobals opts ls = vcat $ map (ppLlvmGlobal opts) ls -- | Print out a global mutable variable definition-ppLlvmGlobal :: LlvmOpts -> LMGlobal -> SDoc+ppLlvmGlobal :: LlvmCgConfig -> LMGlobal -> SDoc ppLlvmGlobal opts (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) = let sect = case x of Just x' -> text ", section" <+> doubleQuotes (ftext x')@@ -108,11 +110,11 @@ -- | Print out a list of LLVM metadata.-ppLlvmMetas :: LlvmOpts -> [MetaDecl] -> SDoc+ppLlvmMetas :: LlvmCgConfig -> [MetaDecl] -> SDoc ppLlvmMetas opts metas = vcat $ map (ppLlvmMeta opts) metas -- | Print out an LLVM metadata definition.-ppLlvmMeta :: LlvmOpts -> MetaDecl -> SDoc+ppLlvmMeta :: LlvmCgConfig -> MetaDecl -> SDoc ppLlvmMeta opts (MetaUnnamed n m) = ppr n <+> equals <+> ppMetaExpr opts m @@ -123,11 +125,11 @@ -- | Print out a list of function definitions.-ppLlvmFunctions :: LlvmOpts -> LlvmFunctions -> SDoc+ppLlvmFunctions :: LlvmCgConfig -> LlvmFunctions -> SDoc ppLlvmFunctions opts funcs = vcat $ map (ppLlvmFunction opts) funcs -- | Print out a function definition.-ppLlvmFunction :: LlvmOpts -> LlvmFunction -> SDoc+ppLlvmFunction :: LlvmCgConfig -> LlvmFunction -> SDoc ppLlvmFunction opts fun = let attrDoc = ppSpaceJoin (funcAttrs fun) secDoc = case funcSect fun of@@ -183,12 +185,12 @@ -- | Print out a list of LLVM blocks.-ppLlvmBlocks :: LlvmOpts -> LlvmBlocks -> SDoc+ppLlvmBlocks :: LlvmCgConfig -> LlvmBlocks -> SDoc ppLlvmBlocks opts blocks = vcat $ map (ppLlvmBlock opts) blocks -- | Print out an LLVM block. -- It must be part of a function definition.-ppLlvmBlock :: LlvmOpts -> LlvmBlock -> SDoc+ppLlvmBlock :: LlvmCgConfig -> LlvmBlock -> SDoc ppLlvmBlock opts (LlvmBlock blockId stmts) = let isLabel (MkLabel _) = True isLabel _ = False@@ -207,7 +209,7 @@ -- | Print out an LLVM statement.-ppLlvmStatement :: LlvmOpts -> LlvmStatement -> SDoc+ppLlvmStatement :: LlvmCgConfig -> LlvmStatement -> SDoc ppLlvmStatement opts stmt = let ind = (text " " <>) in case stmt of@@ -227,7 +229,7 @@ -- | Print out an LLVM expression.-ppLlvmExpression :: LlvmOpts -> LlvmExpression -> SDoc+ppLlvmExpression :: LlvmCgConfig -> LlvmExpression -> SDoc ppLlvmExpression opts expr = case expr of Alloca tp amount -> ppAlloca opts tp amount@@ -249,7 +251,7 @@ Asm asm c ty v se sk -> ppAsm opts asm c ty v se sk MExpr meta expr -> ppMetaAnnotExpr opts meta expr -ppMetaExpr :: LlvmOpts -> MetaExpr -> SDoc+ppMetaExpr :: LlvmCgConfig -> MetaExpr -> SDoc ppMetaExpr opts = \case MetaVar (LMLitVar (LMNullLit _)) -> text "null" MetaStr s -> char '!' <> doubleQuotes (ftext s)@@ -264,7 +266,7 @@ -- | Should always be a function pointer. So a global var of function type -- (since globals are always pointers) or a local var of pointer function type.-ppCall :: LlvmOpts -> LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc+ppCall :: LlvmCgConfig -> LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc ppCall opts ct fptr args attrs = case fptr of -- -- if local var function pointer, unwrap@@ -292,7 +294,7 @@ <> fnty <+> ppName opts fptr <> lparen <+> ppValues <+> rparen <+> attrDoc - ppCallParams :: LlvmOpts -> [[LlvmParamAttr]] -> [MetaExpr] -> SDoc+ ppCallParams :: LlvmCgConfig -> [[LlvmParamAttr]] -> [MetaExpr] -> SDoc ppCallParams opts attrs args = hsep $ punctuate comma $ zipWith ppCallMetaExpr attrs args where -- Metadata needs to be marked as having the `metadata` type when used@@ -301,13 +303,13 @@ ppCallMetaExpr _ v = text "metadata" <+> ppMetaExpr opts v -ppMachOp :: LlvmOpts -> LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc+ppMachOp :: LlvmCgConfig -> LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc ppMachOp opts op left right = (ppr op) <+> (ppr (getVarType left)) <+> ppName opts left <> comma <+> ppName opts right -ppCmpOp :: LlvmOpts -> LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc+ppCmpOp :: LlvmCgConfig -> LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc ppCmpOp opts op left right = let cmpOp | isInt (getVarType left) && isInt (getVarType right) = text "icmp"@@ -322,7 +324,7 @@ <+> ppName opts left <> comma <+> ppName opts right -ppAssignment :: LlvmOpts -> LlvmVar -> SDoc -> SDoc+ppAssignment :: LlvmCgConfig -> LlvmVar -> SDoc -> SDoc ppAssignment opts var expr = ppName opts var <+> equals <+> expr ppFence :: Bool -> LlvmSyncOrdering -> SDoc@@ -352,12 +354,12 @@ ppAtomicOp LAO_Umax = text "umax" ppAtomicOp LAO_Umin = text "umin" -ppAtomicRMW :: LlvmOpts -> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc+ppAtomicRMW :: LlvmCgConfig -> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc ppAtomicRMW opts aop tgt src ordering = text "atomicrmw" <+> ppAtomicOp aop <+> ppVar opts tgt <> comma <+> ppVar opts src <+> ppSyncOrdering ordering -ppCmpXChg :: LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar+ppCmpXChg :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> LlvmSyncOrdering -> SDoc ppCmpXChg opts addr old new s_ord f_ord = text "cmpxchg" <+> ppVar opts addr <> comma <+> ppVar opts old <> comma <+> ppVar opts new@@ -371,16 +373,16 @@ -- access patterns are aligned, in which case we will need a more granular way -- of specifying alignment. -ppLoad :: LlvmOpts -> LlvmVar -> SDoc+ppLoad :: LlvmCgConfig -> LlvmVar -> SDoc ppLoad opts var = text "load" <+> ppr derefType <> comma <+> ppVar opts var <> align where derefType = pLower $ getVarType var align | isVector . pLower . getVarType $ var = text ", align 1" | otherwise = empty -ppALoad :: LlvmOpts -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc+ppALoad :: LlvmCgConfig -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc ppALoad opts ord st var =- let alignment = (llvmWidthInBits (llvmOptsPlatform opts) $ getVarType var) `quot` 8+ let alignment = llvmWidthInBits (llvmCgPlatform opts) (getVarType var) `quot` 8 align = text ", align" <+> ppr alignment sThreaded | st = text " singlethread" | otherwise = empty@@ -388,7 +390,7 @@ in text "load atomic" <+> ppr derefType <> comma <+> ppVar opts var <> sThreaded <+> ppSyncOrdering ord <> align -ppStore :: LlvmOpts -> LlvmVar -> LlvmVar -> SDoc+ppStore :: LlvmCgConfig -> LlvmVar -> LlvmVar -> SDoc ppStore opts val dst | isVecPtrVar dst = text "store" <+> ppVar opts val <> comma <+> ppVar opts dst <> comma <+> text "align 1"@@ -398,7 +400,7 @@ isVecPtrVar = isVector . pLower . getVarType -ppCast :: LlvmOpts -> LlvmCastOp -> LlvmVar -> LlvmType -> SDoc+ppCast :: LlvmCgConfig -> LlvmCastOp -> LlvmVar -> LlvmType -> SDoc ppCast opts op from to = ppr op <+> ppr (getVarType from) <+> ppName opts from@@ -406,19 +408,19 @@ <+> ppr to -ppMalloc :: LlvmOpts -> LlvmType -> Int -> SDoc+ppMalloc :: LlvmCgConfig -> LlvmType -> Int -> SDoc ppMalloc opts tp amount = let amount' = LMLitVar $ LMIntLit (toInteger amount) i32 in text "malloc" <+> ppr tp <> comma <+> ppVar opts amount' -ppAlloca :: LlvmOpts -> LlvmType -> Int -> SDoc+ppAlloca :: LlvmCgConfig -> LlvmType -> Int -> SDoc ppAlloca opts tp amount = let amount' = LMLitVar $ LMIntLit (toInteger amount) i32 in text "alloca" <+> ppr tp <> comma <+> ppVar opts amount' -ppGetElementPtr :: LlvmOpts -> Bool -> LlvmVar -> [LlvmVar] -> SDoc+ppGetElementPtr :: LlvmCgConfig -> Bool -> LlvmVar -> [LlvmVar] -> SDoc ppGetElementPtr opts inb ptr idx = let indexes = comma <+> ppCommaJoin (map (ppVar opts) idx) inbound = if inb then text "inbounds" else empty@@ -427,27 +429,27 @@ <> indexes -ppReturn :: LlvmOpts -> Maybe LlvmVar -> SDoc+ppReturn :: LlvmCgConfig -> Maybe LlvmVar -> SDoc ppReturn opts (Just var) = text "ret" <+> ppVar opts var ppReturn _ Nothing = text "ret" <+> ppr LMVoid -ppBranch :: LlvmOpts -> LlvmVar -> SDoc+ppBranch :: LlvmCgConfig -> LlvmVar -> SDoc ppBranch opts var = text "br" <+> ppVar opts var -ppBranchIf :: LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc+ppBranchIf :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc ppBranchIf opts cond trueT falseT = text "br" <+> ppVar opts cond <> comma <+> ppVar opts trueT <> comma <+> ppVar opts falseT -ppPhi :: LlvmOpts -> LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc+ppPhi :: LlvmCgConfig -> LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc ppPhi opts tp preds = let ppPreds (val, label) = brackets $ ppName opts val <> comma <+> ppName opts label in text "phi" <+> ppr tp <+> hsep (punctuate comma $ map ppPreds preds) -ppSwitch :: LlvmOpts -> LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc+ppSwitch :: LlvmCgConfig -> LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc ppSwitch opts scrut dflt targets = let ppTarget (val, lab) = ppVar opts val <> comma <+> ppVar opts lab ppTargets xs = brackets $ vcat (map ppTarget xs)@@ -455,7 +457,7 @@ <+> ppTargets targets -ppAsm :: LlvmOpts -> LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc+ppAsm :: LlvmCgConfig -> LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc ppAsm opts asm constraints rty vars sideeffect alignstack = let asm' = doubleQuotes $ ftext asm cons = doubleQuotes $ ftext constraints@@ -466,19 +468,19 @@ in text "call" <+> rty' <+> text "asm" <+> side <+> align <+> asm' <> comma <+> cons <> vars' -ppExtract :: LlvmOpts -> LlvmVar -> LlvmVar -> SDoc+ppExtract :: LlvmCgConfig -> LlvmVar -> LlvmVar -> SDoc ppExtract opts vec idx = text "extractelement" <+> ppr (getVarType vec) <+> ppName opts vec <> comma <+> ppVar opts idx -ppExtractV :: LlvmOpts -> LlvmVar -> Int -> SDoc+ppExtractV :: LlvmCgConfig -> LlvmVar -> Int -> SDoc ppExtractV opts struct idx = text "extractvalue" <+> ppr (getVarType struct) <+> ppName opts struct <> comma <+> ppr idx -ppInsert :: LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc+ppInsert :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc ppInsert opts vec elt idx = text "insertelement" <+> ppr (getVarType vec) <+> ppName opts vec <> comma@@ -486,15 +488,15 @@ <+> ppVar opts idx -ppMetaStatement :: LlvmOpts -> [MetaAnnot] -> LlvmStatement -> SDoc+ppMetaStatement :: LlvmCgConfig -> [MetaAnnot] -> LlvmStatement -> SDoc ppMetaStatement opts meta stmt = ppLlvmStatement opts stmt <> ppMetaAnnots opts meta -ppMetaAnnotExpr :: LlvmOpts -> [MetaAnnot] -> LlvmExpression -> SDoc+ppMetaAnnotExpr :: LlvmCgConfig -> [MetaAnnot] -> LlvmExpression -> SDoc ppMetaAnnotExpr opts meta expr = ppLlvmExpression opts expr <> ppMetaAnnots opts meta -ppMetaAnnots :: LlvmOpts -> [MetaAnnot] -> SDoc+ppMetaAnnots :: LlvmCgConfig -> [MetaAnnot] -> SDoc ppMetaAnnots opts meta = hcat $ map ppMeta meta where ppMeta (MetaAnnot name e)@@ -506,7 +508,7 @@ -- | Return the variable name or value of the 'LlvmVar' -- in Llvm IR textual representation (e.g. @\@x@, @%y@ or @42@).-ppName :: LlvmOpts -> LlvmVar -> SDoc+ppName :: LlvmCgConfig -> LlvmVar -> SDoc ppName opts v = case v of LMGlobalVar {} -> char '@' <> ppPlainName opts v LMLocalVar {} -> char '%' <> ppPlainName opts v@@ -515,7 +517,7 @@ -- | Return the variable name or value of the 'LlvmVar' -- in a plain textual representation (e.g. @x@, @y@ or @42@).-ppPlainName :: LlvmOpts -> LlvmVar -> SDoc+ppPlainName :: LlvmCgConfig -> LlvmVar -> SDoc ppPlainName opts v = case v of (LMGlobalVar x _ _ _ _ _) -> ftext x (LMLocalVar x LMLabel ) -> text (show x)@@ -524,13 +526,13 @@ (LMLitVar x ) -> ppLit opts x -- | Print a literal value. No type.-ppLit :: LlvmOpts -> LlvmLit -> SDoc+ppLit :: LlvmCgConfig -> LlvmLit -> SDoc ppLit opts l = case l of (LMIntLit i (LMInt 32)) -> ppr (fromInteger i :: Int32) (LMIntLit i (LMInt 64)) -> ppr (fromInteger i :: Int64) (LMIntLit i _ ) -> ppr ((fromInteger i)::Int)- (LMFloatLit r LMFloat ) -> ppFloat (llvmOptsPlatform opts) $ narrowFp r- (LMFloatLit r LMDouble) -> ppDouble (llvmOptsPlatform opts) r+ (LMFloatLit r LMFloat ) -> ppFloat (llvmCgPlatform opts) $ narrowFp r+ (LMFloatLit r LMDouble) -> ppDouble (llvmCgPlatform opts) r f@(LMFloatLit _ _) -> pprPanic "ppLit" (text "Can't print this float literal: " <> ppTypeLit opts f) (LMVectorLit ls ) -> char '<' <+> ppCommaJoin (map (ppTypeLit opts) ls) <+> char '>' (LMNullLit _ ) -> text "null"@@ -542,27 +544,27 @@ -- common types) with values that are likely to cause a crash or test -- failure. (LMUndefLit t )- | llvmOptsFillUndefWithGarbage opts+ | llvmCgFillUndefWithGarbage opts , Just lit <- garbageLit t -> ppLit opts lit | otherwise -> text "undef" -ppVar :: LlvmOpts -> LlvmVar -> SDoc+ppVar :: LlvmCgConfig -> LlvmVar -> SDoc ppVar = ppVar' [] -ppVar' :: [LlvmParamAttr] -> LlvmOpts -> LlvmVar -> SDoc+ppVar' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmVar -> SDoc ppVar' attrs opts v = case v of LMLitVar x -> ppTypeLit' attrs opts x x -> ppr (getVarType x) <+> ppSpaceJoin attrs <+> ppName opts x -ppTypeLit :: LlvmOpts -> LlvmLit -> SDoc+ppTypeLit :: LlvmCgConfig -> LlvmLit -> SDoc ppTypeLit = ppTypeLit' [] -ppTypeLit' :: [LlvmParamAttr] -> LlvmOpts -> LlvmLit -> SDoc+ppTypeLit' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmLit -> SDoc ppTypeLit' attrs opts l = case l of LMVectorLit {} -> ppLit opts l _ -> ppr (getLitType l) <+> ppSpaceJoin attrs <+> ppLit opts l -ppStatic :: LlvmOpts -> LlvmStatic -> SDoc+ppStatic :: LlvmCgConfig -> LlvmStatic -> SDoc ppStatic opts st = case st of LMComment s -> text "; " <> ftext s LMStaticLit l -> ppTypeLit opts l@@ -578,7 +580,7 @@ LMSub s1 s2 -> pprStaticArith opts s1 s2 (text "sub") (text "fsub") (text "LMSub") -pprSpecialStatic :: LlvmOpts -> LlvmStatic -> SDoc+pprSpecialStatic :: LlvmCgConfig -> LlvmStatic -> SDoc pprSpecialStatic opts stat = case stat of LMBitc v t -> ppr (pLower t) <> text ", bitcast ("@@ -589,7 +591,7 @@ _ -> ppStatic opts stat -pprStaticArith :: LlvmOpts -> LlvmStatic -> LlvmStatic -> SDoc -> SDoc+pprStaticArith :: LlvmCgConfig -> LlvmStatic -> LlvmStatic -> SDoc -> SDoc -> SDoc -> SDoc pprStaticArith opts s1 s2 int_op float_op op_name = let ty1 = getStatType s1
compiler/GHC/Llvm/Types.hs view
@@ -13,7 +13,6 @@ import Numeric import GHC.Platform-import GHC.Driver.Session import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic@@ -155,21 +154,6 @@ -- ----------------------------------------------------------------------------- -- ** Operations on LLVM Basic Types and Variables ------ | LLVM code generator options-data LlvmOpts = LlvmOpts- { llvmOptsPlatform :: !Platform -- ^ Target platform- , llvmOptsFillUndefWithGarbage :: !Bool -- ^ Fill undefined literals with garbage values- , llvmOptsSplitSections :: !Bool -- ^ Split sections- }---- | Get LlvmOptions from DynFlags-initLlvmOpts :: DynFlags -> LlvmOpts-initLlvmOpts dflags = LlvmOpts- { llvmOptsPlatform = targetPlatform dflags- , llvmOptsFillUndefWithGarbage = gopt Opt_LlvmFillUndefWithGarbage dflags- , llvmOptsSplitSections = gopt Opt_SplitSections dflags- } garbageLit :: LlvmType -> Maybe LlvmLit garbageLit t@(LMInt w) = Just (LMIntLit (0xbbbbbbbbbbbbbbb0 `mod` (2^w)) t)
compiler/GHC/Rename/Expr.hs view
@@ -607,11 +607,11 @@ Note [Desugaring operator sections] Here are their definitions:- leftSection :: forall r1 r2 n (a:TYPE r1) (b:TYPE r2).+ leftSection :: forall r1 r2 n (a::TYPE r1) (b::TYPE r2). (a %n-> b) -> a %n-> b leftSection f x = f x - rightSection :: forall r1 r2 r3 (a:TYPE r1) (b:TYPE r2) (c:TYPE r3).+ rightSection :: forall r1 r2 r3 n1 n2 (a::TYPE r1) (b::TYPE r2) (c::TYPE r3). (a %n1 -> b %n2-> c) -> b %n2-> a %n1-> c rightSection f y x = f x y @@ -623,13 +623,13 @@ Plus, infix operator applications would be trickier to make rebindable, so it'd be inconsistent to do so for sections. - TL;DR: we still us the renamer-expansion mechanism for operator- sections , but only to eliminate special-purpose code paths in the+ TL;DR: we still use the renamer-expansion mechanism for operator+ sections, but only to eliminate special-purpose code paths in the renamer and desugarer. * leftSection and rightSection must be representation-polymorphic, to allow- (+# 4#) and (4# +#) to work. See GHC.Types.Id.Make.- Note [Wired-in Ids for rebindable syntax] in+ (+# 4#) and (4# +#) to work. See+ Note [Wired-in Ids for rebindable syntax] in GHC.Types.Id.Make. * leftSection and rightSection must be multiplicity-polymorphic. (Test linear/should_compile/OldList showed this up.)@@ -2159,7 +2159,7 @@ (\(x,y) -> \z -> C) <$> A <*> B -then it could be lazier than the standard desuraging using >>=. See #13875+then it could be lazier than the standard desugaring using >>=. See #13875 for more examples. Thus, whenever we have a strict pattern match, we treat it as a
compiler/GHC/Rename/Names.hs view
@@ -73,7 +73,6 @@ import GHC.Types.SourceText import GHC.Types.Id import GHC.Types.HpcInfo-import GHC.Types.Unique.FM import GHC.Types.Error import GHC.Types.PkgQual @@ -217,7 +216,7 @@ clobberSourceImports imp_avails = imp_avails { imp_boot_mods = imp_boot_mods' } where- imp_boot_mods' = mergeUFM combJ id (const mempty)+ imp_boot_mods' = mergeInstalledModuleEnv combJ id (const emptyInstalledModuleEnv) (imp_boot_mods imp_avails) (imp_direct_dep_mods imp_avails) @@ -327,8 +326,9 @@ let imp_mod_name = unLoc loc_imp_mod_name doc = ppr imp_mod_name <+> import_reason + hsc_env <- getTopEnv unit_env <- hsc_unit_env <$> getTopEnv- let pkg_qual = renameRawPkgQual unit_env raw_pkg_qual+ let pkg_qual = renameRawPkgQual unit_env imp_mod_name raw_pkg_qual -- Check for self-import, which confuses the typechecker (#9032) -- ghc --make rejects self-import cycles already, but batch-mode may not@@ -348,7 +348,7 @@ -- or the name of this_mod's package. Yurgh! -- c.f. GHC.findModule, and #9997 NoPkgQual -> True- ThisPkg _ -> True+ ThisPkg uid -> uid == homeUnitId_ (hsc_dflags hsc_env) OtherPkg _ -> False)) (addErr $ TcRnUnknownMessage $ mkPlainError noHints $ (text "A module cannot import itself:" <+> ppr imp_mod_name))@@ -413,6 +413,7 @@ hsc_env <- getTopEnv let home_unit = hsc_home_unit hsc_env+ other_home_units = hsc_all_home_unit_ids hsc_env imv = ImportedModsVal { imv_name = qual_mod_name , imv_span = locA loc@@ -421,7 +422,7 @@ , imv_all_exports = potential_gres , imv_qualified = qual_only }- imports = calculateAvails home_unit iface mod_safe' want_boot (ImportedByUser imv)+ imports = calculateAvails home_unit other_home_units iface mod_safe' want_boot (ImportedByUser imv) -- Complain if we import a deprecated module case mi_warns iface of@@ -453,37 +454,49 @@ -- | Rename raw package imports-renameRawPkgQual :: UnitEnv -> RawPkgQual -> PkgQual-renameRawPkgQual unit_env = \case+renameRawPkgQual :: UnitEnv -> ModuleName -> RawPkgQual -> PkgQual+renameRawPkgQual unit_env mn = \case NoRawPkgQual -> NoPkgQual- RawPkgQual p -> renamePkgQual unit_env (Just (sl_fs p))+ RawPkgQual p -> renamePkgQual unit_env mn (Just (sl_fs p)) -- | Rename raw package imports-renamePkgQual :: UnitEnv -> Maybe FastString -> PkgQual-renamePkgQual unit_env mb_pkg = case mb_pkg of+renamePkgQual :: UnitEnv -> ModuleName -> Maybe FastString -> PkgQual+renamePkgQual unit_env mn mb_pkg = case mb_pkg of Nothing -> NoPkgQual Just pkg_fs- | Just uid <- homeUnitId <$> ue_home_unit unit_env- , pkg_fs == fsLit "this" || pkg_fs == unitFS uid+ | Just uid <- homeUnitId <$> ue_homeUnit unit_env+ , pkg_fs == fsLit "this" -> ThisPkg uid - | Just uid <- lookupPackageName (ue_units unit_env) (PackageName pkg_fs)+ | Just (uid, _) <- find (fromMaybe False . fmap (== pkg_fs) . snd) home_names+ -> ThisPkg uid++ | Just uid <- resolvePackageImport (ue_units unit_env) mn (PackageName pkg_fs) -> OtherPkg uid | otherwise -> OtherPkg (UnitId pkg_fs) -- not really correct as pkg_fs is unlikely to be a valid unit-id but -- we will report the failure later...+ where+ home_names = map (\uid -> (uid, mkFastString <$> thisPackageName (homeUnitEnv_dflags (ue_findHomeUnitEnv uid unit_env)))) hpt_deps + units = ue_units unit_env++ hpt_deps :: [UnitId]+ hpt_deps = homeUnitDepends units++ -- | Calculate the 'ImportAvails' induced by an import of a particular -- interface, but without 'imp_mods'. calculateAvails :: HomeUnit+ -> S.Set UnitId -> ModIface -> IsSafeImport -> IsBootInterface -> ImportedBy -> ImportAvails-calculateAvails home_unit iface mod_safe' want_boot imported_by =+calculateAvails home_unit other_home_units iface mod_safe' want_boot imported_by = let imp_mod = mi_module iface imp_sem_mod= mi_semantic_module iface orph_iface = mi_orphan (mi_final_exts iface)@@ -545,24 +558,24 @@ | isHomeUnit home_unit pkg = ptrust | otherwise = False - dependent_pkgs = if isHomeUnit home_unit pkg+ dependent_pkgs = if toUnitId pkg `S.member` other_home_units then S.empty else S.singleton ipkg - direct_mods = mkModDeps $ if isHomeUnit home_unit pkg- then S.singleton (GWIB (moduleName imp_mod) want_boot)+ direct_mods = mkModDeps $ if toUnitId pkg `S.member` other_home_units+ then S.singleton (moduleUnitId imp_mod, (GWIB (moduleName imp_mod) want_boot)) else S.empty dep_boot_mods_map = mkModDeps (dep_boot_mods deps) boot_mods -- If we are looking for a boot module, it must be HPT- | IsBoot <- want_boot = addToUFM dep_boot_mods_map (moduleName imp_mod) (GWIB (moduleName imp_mod) IsBoot)+ | IsBoot <- want_boot = extendInstalledModuleEnv dep_boot_mods_map (toUnitId <$> imp_mod) (GWIB (moduleName imp_mod) IsBoot) -- Now we are importing A properly, so don't go looking for -- A.hs-boot | isHomeUnit home_unit pkg = dep_boot_mods_map -- There's no boot files to find in external imports- | otherwise = emptyUFM+ | otherwise = emptyInstalledModuleEnv sig_mods = if is_sig@@ -594,8 +607,6 @@ -- | Issue a warning if the user imports Data.List without either an import -- list or `qualified`. This is part of the migration plan for the -- `Data.List.singleton` proposal. See #17244.------ Currently not used for anything. warnUnqualifiedImport :: ImportDecl GhcPs -> ModIface -> RnM () warnUnqualifiedImport decl iface = when bad_import $ do@@ -627,8 +638,7 @@ ] -- Modules for which we warn if we see unqualified imports- -- Currently empty.- qualifiedMods = mkModuleSet []+ qualifiedMods = mkModuleSet [ dATA_LIST ] warnRedundantSourceImport :: ModuleName -> TcRnMessage
compiler/GHC/Runtime/Eval.hs view
@@ -134,6 +134,7 @@ import GHC.Tc.Solver (simplifyWantedsTcM) import GHC.Tc.Utils.Monad import GHC.Core.Class (classTyCon)+import GHC.Unit.Env -- ----------------------------------------------------------------------------- -- running a statement interactively@@ -150,7 +151,7 @@ getHistorySpan :: HscEnv -> History -> SrcSpan getHistorySpan hsc_env History{..} = let BreakInfo{..} = historyBreakInfo in- case lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module) of+ case lookupHugByModule breakInfo_module (hsc_HUG hsc_env) of Just hmi -> modBreaks_locs (getModBreaks hmi) ! breakInfo_number _ -> panic "getHistorySpan" @@ -161,7 +162,7 @@ findEnclosingDecls :: HscEnv -> BreakInfo -> [String] findEnclosingDecls hsc_env (BreakInfo modl ix) = let hmi = expectJust "findEnclosingDecls" $- lookupHpt (hsc_HPT hsc_env) (moduleName modl)+ lookupHugByModule modl (hsc_HUG hsc_env) mb = getModBreaks hmi in modBreaks_decls mb ! ix @@ -1248,8 +1249,7 @@ withSession $ \hsc_env -> do interpreted <- moduleIsBootOrNotObjectLinkable mod_summary let dflags = hsc_dflags hsc_env- -- extendModSummaryNoDeps because the message doesn't look at the deps- return (showSDoc dflags $ showModMsg dflags interpreted (ModuleNode (extendModSummaryNoDeps mod_summary)))+ return (showSDoc dflags $ showModMsg dflags interpreted (ModuleNode [] mod_summary)) moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env ->
compiler/GHC/Runtime/Heap/Inspect.hs view
@@ -839,8 +839,7 @@ traceTR (text "Not constructor" <+> ppr dcname) let dflags = hsc_dflags hsc_env tag = showPpr dflags dcname- vars <- replicateM (length pArgs)- (newVar liftedTypeKind)+ vars <- mapM (const (newVar liftedTypeKind)) pArgs subTerms <- sequence $ zipWith (\x tv -> go (pred max_depth) tv tv x) pArgs vars return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
compiler/GHC/Runtime/Loader.hs view
@@ -74,14 +74,16 @@ initializePlugins :: HscEnv -> Maybe ModuleNameWithIsBoot -> IO HscEnv initializePlugins hsc_env mnwib -- plugins not changed- | map lpModuleName (hsc_plugins hsc_env) == pluginModNames dflags+ | loaded_plugins <- loadedPlugins (hsc_plugins hsc_env)+ , map lpModuleName loaded_plugins == reverse (pluginModNames dflags) -- arguments not changed- , all same_args (hsc_plugins hsc_env)- = return hsc_env -- no need to reload plugins+ , all same_args loaded_plugins+ = return hsc_env -- no need to reload plugins FIXME: doesn't take static plugins into account | otherwise = do loaded_plugins <- loadPlugins hsc_env mnwib- let hsc_env' = hsc_env { hsc_plugins = loaded_plugins }- withPlugins hsc_env' driverPlugin hsc_env'+ let plugins' = (hsc_plugins hsc_env) { loadedPlugins = loaded_plugins }+ let hsc_env' = hsc_env { hsc_plugins = plugins' }+ withPlugins (hsc_plugins hsc_env') driverPlugin hsc_env' where plugin_args = pluginModNameOpts dflags same_args p = paArguments (lpPlugin p) == argumentsForPlugin p plugin_args@@ -96,7 +98,7 @@ ; return $ zipWith attachOptions to_load plugins } where dflags = hsc_dflags hsc_env- to_load = pluginModNames dflags+ to_load = reverse $ pluginModNames dflags attachOptions mod_nm (plug, mod) = LoadedPlugin (PluginWithArgs plug (reverse options)) mod@@ -268,7 +270,7 @@ let fc = hsc_FC hsc_env let unit_env = hsc_unit_env hsc_env let unit_state = ue_units unit_env- let mhome_unit = ue_home_unit unit_env+ let mhome_unit = hsc_home_unit_maybe hsc_env -- First find the unit the module resides in by searching exposed units and home modules found_module <- findPluginModule fc fopts unit_state mhome_unit mod_name case found_module of
compiler/GHC/StgToCmm/Prim.hs view
@@ -39,6 +39,7 @@ import GHC.Core.Type ( Type, tyConAppTyCon ) import GHC.Core.TyCon import GHC.Cmm.CLabel+import GHC.Cmm.Info ( closureInfoPtr ) import GHC.Cmm.Utils import GHC.Builtin.PrimOps import GHC.Runtime.Heap.Layout@@ -303,11 +304,17 @@ -- MutVar's value. emitPrimCall res MO_WriteBarrier [] emitStore (cmmOffsetW platform mutv (fixedHdrSizeW profile)) var- emitCCall- [{-no results-}]- (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))- [(baseExpr, AddrHint), (mutv, AddrHint), (CmmReg old_val, AddrHint)] + ptrOpts <- getPtrOpts+ platform <- getPlatform+ mkdirtyMutVarCCall <- getCode $! emitCCall+ [{-no results-}]+ (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))+ [(baseExpr, AddrHint), (mutv, AddrHint), (CmmReg old_val, AddrHint)]+ emit =<< mkCmmIfThen+ (cmmEqWord platform (mkLblExpr mkMUT_VAR_CLEAN_infoLabel) (closureInfoPtr ptrOpts mutv))+ mkdirtyMutVarCCall+ -- #define sizzeofByteArrayzh(r,a) \ -- r = ((StgArrBytes *)(a))->bytes SizeofByteArrayOp -> \[arg] -> opIntoRegs $ \[res] ->@@ -2121,6 +2128,7 @@ -> FCode () doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx] = do profile <- getProfile+ doByteArrayBoundsCheck idx addr rep rep mkBasicIndexedRead (arrWordsHdrSize profile) maybe_post_read_cast rep res addr rep idx doIndexByteArrayOp _ _ _ _ = panic "GHC.StgToCmm.Prim: doIndexByteArrayOp"@@ -2133,6 +2141,7 @@ -> FCode () doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx] = do profile <- getProfile+ doByteArrayBoundsCheck idx addr idx_rep rep mkBasicIndexedRead (arrWordsHdrSize profile) maybe_post_read_cast rep res addr idx_rep idx doIndexByteArrayOpAs _ _ _ _ _ = panic "GHC.StgToCmm.Prim: doIndexByteArrayOpAs"@@ -2144,6 +2153,7 @@ doReadPtrArrayOp res addr idx = do profile <- getProfile platform <- getPlatform+ doPtrArrayBoundsCheck idx addr mkBasicIndexedRead (arrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx doWriteOffAddrOp :: Maybe MachOp@@ -2163,6 +2173,8 @@ -> FCode () doWriteByteArrayOp maybe_pre_write_cast idx_ty [] [addr,idx,val] = do profile <- getProfile+ platform <- getPlatform+ doByteArrayBoundsCheck idx addr idx_ty (cmmExprType platform val) mkBasicIndexedWrite (arrWordsHdrSize profile) maybe_pre_write_cast addr idx_ty idx val doWriteByteArrayOp _ _ _ _ = panic "GHC.StgToCmm.Prim: doWriteByteArrayOp"@@ -2176,6 +2188,9 @@ platform <- getPlatform let ty = cmmExprType platform val hdr_size = arrPtrsHdrSize profile++ doPtrArrayBoundsCheck idx addr+ -- Update remembered set for non-moving collector whenUpdRemSetEnabled $ emitUpdRemSetPush (cmmLoadIndexOffExpr platform hdr_size ty addr ty idx)@@ -2184,6 +2199,7 @@ -- See #12469 for details. emitPrimCall [] MO_WriteBarrier [] mkBasicIndexedWrite hdr_size Nothing addr ty idx val+ emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) -- the write barrier. We must write a byte into the mark table: -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]@@ -2540,6 +2556,12 @@ doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n = do profile <- getProfile platform <- getPlatform++ ifNonZero n $ do+ let last_touched_idx off = cmmOffset platform (cmmAddWord platform off n) (-1)+ doByteArrayBoundsCheck ba1_off (last_touched_idx ba1_off) b8 b8+ doByteArrayBoundsCheck ba2_off (last_touched_idx ba2_off) b8 b8+ ba1_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba1 (arrWordsHdrSize profile)) ba1_off ba2_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba2 (arrWordsHdrSize profile)) ba2_off @@ -2629,6 +2651,12 @@ emitCopyByteArray copy src src_off dst dst_off n = do profile <- getProfile platform <- getPlatform++ ifNonZero n $ do+ let last_touched_idx off = cmmOffset platform (cmmAddWord platform off n) (-1)+ doByteArrayBoundsCheck (last_touched_idx src_off) src b8 b8+ doByteArrayBoundsCheck (last_touched_idx dst_off) dst b8 b8+ let byteArrayAlignment = wordAlignment platform srcOffAlignment = cmmExprAlignment src_off dstOffAlignment = cmmExprAlignment dst_off@@ -2645,6 +2673,9 @@ -- Use memcpy (we are allowed to assume the arrays aren't overlapping) profile <- getProfile platform <- getPlatform+ ifNonZero bytes $ do+ let last_touched_idx off = cmmOffset platform (cmmAddWord platform off bytes) (-1)+ doByteArrayBoundsCheck (last_touched_idx src_off) src b8 b8 src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize profile)) src_off emitMemcpyCall dst_p src_p bytes (mkAlignment 1) @@ -2663,9 +2694,18 @@ -- Use memcpy (we are allowed to assume the arrays aren't overlapping) profile <- getProfile platform <- getPlatform+ ifNonZero bytes $ do+ let last_touched_idx off = cmmOffset platform (cmmAddWord platform off bytes) (-1)+ doByteArrayBoundsCheck (last_touched_idx dst_off) dst b8 b8 dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize profile)) dst_off emitMemcpyCall dst_p src_p bytes (mkAlignment 1) +ifNonZero :: CmmExpr -> FCode () -> FCode ()+ifNonZero e it = do+ platform <- getPlatform+ let pred = cmmNeWord platform e (zeroExpr platform)+ code <- getCode it+ emit =<< mkCmmIfThen' pred code (Just False) -- ---------------------------------------------------------------------------- -- Setting byte arrays@@ -2679,6 +2719,9 @@ profile <- getProfile platform <- getPlatform + doByteArrayBoundsCheck off ba b8 b8+ doByteArrayBoundsCheck (cmmAddWord platform off c) ba b8 b8+ let byteArrayAlignment = wordAlignment platform -- known since BA is allocated on heap offsetAlignment = cmmExprAlignment off align = min byteArrayAlignment offsetAlignment@@ -2790,6 +2833,9 @@ dst <- assignTempE dst0 dst_off <- assignTempE dst_off0 + doPtrArrayBoundsCheck (cmmAddWord platform src_off (mkIntExpr platform n)) src+ doPtrArrayBoundsCheck (cmmAddWord platform dst_off (mkIntExpr platform n)) dst+ -- Nonmoving collector write barrier emitCopyUpdRemSetPush platform (arrPtrsHdrSize profile) dst dst_off n @@ -2856,6 +2902,10 @@ src <- assignTempE src0 dst <- assignTempE dst0 + when (n /= 0) $ do+ doSmallPtrArrayBoundsCheck (cmmAddWord platform src_off (mkIntExpr platform n)) src+ doSmallPtrArrayBoundsCheck (cmmAddWord platform dst_off (mkIntExpr platform n)) dst+ -- Nonmoving collector write barrier emitCopyUpdRemSetPush platform (smallArrPtrsHdrSize profile) dst dst_off n @@ -2981,6 +3031,7 @@ doReadSmallPtrArrayOp res addr idx = do profile <- getProfile platform <- getPlatform+ doSmallPtrArrayBoundsCheck idx addr mkBasicIndexedRead (smallArrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx @@ -2993,6 +3044,8 @@ platform <- getPlatform let ty = cmmExprType platform val + doSmallPtrArrayBoundsCheck idx addr+ -- Update remembered set for non-moving collector tmp <- newTemp ty mkBasicIndexedRead (smallArrPtrsHdrSize profile) Nothing ty tmp addr ty idx@@ -3019,6 +3072,7 @@ doAtomicByteArrayRMW res amop mba idx idx_ty n = do profile <- getProfile platform <- getPlatform+ doByteArrayBoundsCheck idx mba idx_ty idx_ty let width = typeWidth idx_ty addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) width mba idx@@ -3047,6 +3101,7 @@ doAtomicReadByteArray res mba idx idx_ty = do profile <- getProfile platform <- getPlatform+ doByteArrayBoundsCheck idx mba idx_ty idx_ty let width = typeWidth idx_ty addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) width mba idx@@ -3074,6 +3129,7 @@ doAtomicWriteByteArray mba idx idx_ty val = do profile <- getProfile platform <- getPlatform+ doByteArrayBoundsCheck idx mba idx_ty idx_ty let width = typeWidth idx_ty addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) width mba idx@@ -3102,6 +3158,7 @@ doCasByteArray res mba idx idx_ty old new = do profile <- getProfile platform <- getPlatform+ doByteArrayBoundsCheck idx mba idx_ty idx_ty let width = typeWidth idx_ty addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) width mba idx@@ -3210,6 +3267,74 @@ [ res ] (MO_Ctz width) [ x ]++---------------------------------------------------------------------------+-- Array bounds checking+---------------------------------------------------------------------------++doBoundsCheck :: CmmExpr -- ^ accessed index+ -> CmmExpr -- ^ array size (in elements)+ -> FCode ()+doBoundsCheck idx sz = do+ dflags <- getDynFlags+ platform <- getPlatform+ when (gopt Opt_DoBoundsChecking dflags) (doCheck platform)+ where+ doCheck platform = do+ boundsCheckFailed <- getCode $ emitCCall [] (mkLblExpr mkOutOfBoundsAccessLabel) []+ emit =<< mkCmmIfThen' isOutOfBounds boundsCheckFailed (Just False)+ where+ uGE = cmmUGeWord platform+ and = cmmAndWord platform+ zero = zeroExpr platform+ ne = cmmNeWord platform+ isOutOfBounds = ((idx `uGE` sz) `and` (idx `ne` zero)) `ne` zero++-- We want to make sure that the array size computation is pushed into the+-- Opt_DoBoundsChecking check to avoid regregressing compiler performance when+-- it's disabled.+{-# INLINE doBoundsCheck #-}++doPtrArrayBoundsCheck+ :: CmmExpr -- ^ accessed index (in bytes)+ -> CmmExpr -- ^ pointer to @StgMutArrPtrs@+ -> FCode ()+doPtrArrayBoundsCheck idx arr = do+ profile <- getProfile+ platform <- getPlatform+ let sz = CmmLoad (cmmOffset platform arr sz_off) (bWord platform)+ sz_off = fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform)+ doBoundsCheck idx sz++doSmallPtrArrayBoundsCheck+ :: CmmExpr -- ^ accessed index (in bytes)+ -> CmmExpr -- ^ pointer to @StgMutArrPtrs@+ -> FCode ()+doSmallPtrArrayBoundsCheck idx arr = do+ profile <- getProfile+ platform <- getPlatform+ let sz = CmmLoad (cmmOffset platform arr sz_off) (bWord platform)+ sz_off = fixedHdrSize profile + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)+ doBoundsCheck idx sz++doByteArrayBoundsCheck+ :: CmmExpr -- ^ accessed index (in elements)+ -> CmmExpr -- ^ pointer to @StgArrBytes@+ -> CmmType -- ^ indexing type+ -> CmmType -- ^ element type+ -> FCode ()+doByteArrayBoundsCheck idx arr idx_ty elem_ty = do+ profile <- getProfile+ platform <- getPlatform+ let sz = CmmLoad (cmmOffset platform arr sz_off) (bWord platform)+ sz_off = fixedHdrSize profile + pc_OFFSET_StgArrBytes_bytes (platformConstants platform)+ elem_sz = widthInBytes $ typeWidth elem_ty+ idx_sz = widthInBytes $ typeWidth idx_ty+ -- Ensure that the last byte of the access is within the array+ idx_bytes = cmmOffsetB platform+ (cmmMulWord platform idx (mkIntExpr platform idx_sz))+ (elem_sz - 1)+ doBoundsCheck idx_bytes sz --------------------------------------------------------------------------- -- Pushing to the update remembered set
compiler/GHC/StgToCmm/Ticky.hs view
@@ -675,20 +675,21 @@ | otherwise = case tcSplitTyConApp_maybe ty of Nothing -> '.' Just (tycon, _) ->- (if isUnliftedTyCon tycon then Data.Char.toLower else id) $ let anyOf us = getUnique tycon `elem` us in case () of _ | anyOf [funTyConKey] -> '>'- | anyOf [charPrimTyConKey, charTyConKey] -> 'C'- | anyOf [doublePrimTyConKey, doubleTyConKey] -> 'D'- | anyOf [floatPrimTyConKey, floatTyConKey] -> 'F'- | anyOf [intPrimTyConKey, int32PrimTyConKey, int64PrimTyConKey,- intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey- ] -> 'I'- | anyOf [wordPrimTyConKey, word32PrimTyConKey, word64PrimTyConKey, wordTyConKey,- word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey- ] -> 'W'+ | anyOf [charTyConKey] -> 'C'+ | anyOf [charPrimTyConKey] -> 'c'+ | anyOf [doubleTyConKey] -> 'D'+ | anyOf [doublePrimTyConKey] -> 'd'+ | anyOf [floatTyConKey] -> 'F'+ | anyOf [floatPrimTyConKey] -> 'f'+ | anyOf [intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey] -> 'I'+ | anyOf [intPrimTyConKey, int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int64PrimTyConKey] -> 'i'+ | anyOf [wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey] -> 'W'+ | anyOf [wordPrimTyConKey, word8PrimTyConKey, word16PrimTyConKey, word32PrimTyConKey, word64PrimTyConKey] -> 'w' | anyOf [listTyConKey] -> 'L'+ | isUnboxedTupleTyCon tycon -> 't' | isTupleTyCon tycon -> 'T' | isPrimTyCon tycon -> 'P' | isEnumerationTyCon tycon -> 'E'
compiler/GHC/SysTools/Tasks.hs view
@@ -14,7 +14,8 @@ import GHC.ForeignSrcLang import GHC.IO (catchException) -import GHC.CmmToLlvm.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound, llvmVersionStr, parseLlvmVersion)+import GHC.CmmToLlvm.Base (llvmVersionStr, supportedLlvmVersionUpperBound, parseLlvmVersion, supportedLlvmVersionLowerBound)+import GHC.CmmToLlvm.Config (LlvmVersion) import GHC.SysTools.Process import GHC.SysTools.Info@@ -48,10 +49,21 @@ runSomething logger "Literate pre-processor" prog (map Option opts ++ args) +-- | Prepend the working directory to the search path.+-- Note [Filepaths and Multiple Home Units]+augmentImports :: DynFlags -> [FilePath] -> [FilePath]+augmentImports dflags fps | Nothing <- workingDirectory dflags = fps+augmentImports _ [] = []+augmentImports _ [x] = [x]+augmentImports dflags ("-include":fp:fps) = "-include" : augmentByWorkingDirectory dflags fp : augmentImports dflags fps+augmentImports dflags (fp1: fp2: fps) = fp1 : augmentImports dflags (fp2:fps)+ runCpp :: Logger -> DynFlags -> [Option] -> IO () runCpp logger dflags args = traceToolCommand logger "cpp" $ do+ let opts = getOpts dflags opt_P+ modified_imports = augmentImports dflags opts let (p,args0) = pgm_P dflags- args1 = map Option (getOpts dflags opt_P)+ args1 = map Option modified_imports args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags] ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags] mb_env <- getGccEnv args2
compiler/GHC/Tc/Gen/App.hs view
@@ -954,7 +954,7 @@ Suppose 'wurble' is not in scope, and we have (wurble @Int @Bool True 'x') -Then the renamer will make (HsUnboundVar "wurble) for 'wurble',+Then the renamer will make (HsUnboundVar "wurble") for 'wurble', and the typechecker will typecheck it with tcUnboundId, giving it a type 'alpha', and emitting a deferred Hole constraint, to be reported later.@@ -978,7 +978,7 @@ that may abandon an entire instance decl, which (in the presence of -fdefer-type-errors) leads to leading to #17792. -Downside; the typechecked term has lost its visible type arguments; we+Downside: the typechecked term has lost its visible type arguments; we don't even kind-check them. But let's jump that bridge if we come to it. Meanwhile, let's not crash!
compiler/GHC/Tc/Gen/Export.hs view
@@ -174,7 +174,7 @@ , tcg_rdr_env = rdr_env , tcg_imports = imports , tcg_src = hsc_src } = tcg_env- default_main | mainModIs hsc_env == this_mod+ default_main | mainModIs (hsc_HUE hsc_env) == this_mod , Just main_fun <- mainFunIs dflags = mkUnqual varName (fsLit main_fun) | otherwise
compiler/GHC/Tc/Gen/Splice.hs view
@@ -988,13 +988,13 @@ -- to carry on. Mind you, the staging restrictions mean we won't -- actually run f, but it still seems wrong. And, more concretely, -- see #5358 for an example that fell over when trying to- -- reify a function with a "?" kind in it. (These don't occur+ -- reify a function with an unlifted kind in it. (These don't occur -- in type-correct programs.) ; failIfErrsM -- run plugins ; hsc_env <- getTopEnv- ; expr' <- withPlugins hsc_env spliceRunAction expr+ ; expr' <- withPlugins (hsc_plugins hsc_env) spliceRunAction expr -- Desugar ; (ds_msgs, mb_ds_expr) <- initDsTc (dsLExpr expr')@@ -1209,6 +1209,10 @@ -- we'll only fail higher up. qRecover recover main = tryTcDiscardingErrs recover main + qGetPackageRoot = do+ dflags <- getDynFlags+ return $ fromMaybe "." (workingDirectory dflags)+ qAddDependentFile fp = do ref <- fmap tcg_dependent_files getGblEnv dep_files <- readTcRef ref@@ -1401,33 +1405,35 @@ -- > inst_cls_name (Monad Maybe) == Monad -- > inst_cls_name C = C inst_cls_name :: TH.Type -> TcM TH.Name- inst_cls_name (TH.AppT t _) = inst_cls_name t- inst_cls_name (TH.SigT n _) = inst_cls_name n- inst_cls_name (TH.VarT n) = pure n- inst_cls_name (TH.ConT n) = pure n- inst_cls_name (TH.PromotedT n) = pure n- inst_cls_name (TH.InfixT _ n _) = pure n- inst_cls_name (TH.UInfixT _ n _) = pure n- inst_cls_name (TH.ParensT t) = inst_cls_name t+ inst_cls_name (TH.AppT t _) = inst_cls_name t+ inst_cls_name (TH.SigT n _) = inst_cls_name n+ inst_cls_name (TH.VarT n) = pure n+ inst_cls_name (TH.ConT n) = pure n+ inst_cls_name (TH.PromotedT n) = pure n+ inst_cls_name (TH.InfixT _ n _) = pure n+ inst_cls_name (TH.UInfixT _ n _) = pure n+ inst_cls_name (TH.PromotedInfixT _ n _) = pure n+ inst_cls_name (TH.PromotedUInfixT _ n _) = pure n+ inst_cls_name (TH.ParensT t) = inst_cls_name t - inst_cls_name (TH.ForallT _ _ _) = inst_cls_name_err- inst_cls_name (TH.ForallVisT _ _) = inst_cls_name_err- inst_cls_name (TH.AppKindT _ _) = inst_cls_name_err- inst_cls_name (TH.TupleT _) = inst_cls_name_err- inst_cls_name (TH.UnboxedTupleT _) = inst_cls_name_err- inst_cls_name (TH.UnboxedSumT _) = inst_cls_name_err- inst_cls_name TH.ArrowT = inst_cls_name_err- inst_cls_name TH.MulArrowT = inst_cls_name_err- inst_cls_name TH.EqualityT = inst_cls_name_err- inst_cls_name TH.ListT = inst_cls_name_err- inst_cls_name (TH.PromotedTupleT _) = inst_cls_name_err- inst_cls_name TH.PromotedNilT = inst_cls_name_err- inst_cls_name TH.PromotedConsT = inst_cls_name_err- inst_cls_name TH.StarT = inst_cls_name_err- inst_cls_name TH.ConstraintT = inst_cls_name_err- inst_cls_name (TH.LitT _) = inst_cls_name_err- inst_cls_name TH.WildCardT = inst_cls_name_err- inst_cls_name (TH.ImplicitParamT _ _) = inst_cls_name_err+ inst_cls_name (TH.ForallT _ _ _) = inst_cls_name_err+ inst_cls_name (TH.ForallVisT _ _) = inst_cls_name_err+ inst_cls_name (TH.AppKindT _ _) = inst_cls_name_err+ inst_cls_name (TH.TupleT _) = inst_cls_name_err+ inst_cls_name (TH.UnboxedTupleT _) = inst_cls_name_err+ inst_cls_name (TH.UnboxedSumT _) = inst_cls_name_err+ inst_cls_name TH.ArrowT = inst_cls_name_err+ inst_cls_name TH.MulArrowT = inst_cls_name_err+ inst_cls_name TH.EqualityT = inst_cls_name_err+ inst_cls_name TH.ListT = inst_cls_name_err+ inst_cls_name (TH.PromotedTupleT _) = inst_cls_name_err+ inst_cls_name TH.PromotedNilT = inst_cls_name_err+ inst_cls_name TH.PromotedConsT = inst_cls_name_err+ inst_cls_name TH.StarT = inst_cls_name_err+ inst_cls_name TH.ConstraintT = inst_cls_name_err+ inst_cls_name (TH.LitT _) = inst_cls_name_err+ inst_cls_name TH.WildCardT = inst_cls_name_err+ inst_cls_name (TH.ImplicitParamT _ _) = inst_cls_name_err inst_cls_name_err = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text "Couldn't work out what instance"@@ -1625,6 +1631,7 @@ wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep) ReifyModule m -> wrapTHResult $ TH.qReifyModule m ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm+ GetPackageRoot -> wrapTHResult $ TH.qGetPackageRoot AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f AddTempFile s -> wrapTHResult $ TH.qAddTempFile s AddModFinalizer r -> do@@ -1914,7 +1921,7 @@ | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (length (tyConVisibleTyVars tc))- (isUnliftedTyCon tc))+ (isUnliftedTypeKind (tyConResKind tc))) | isTypeFamilyTyCon tc = do { let tvs = tyConTyVars tc
compiler/GHC/Tc/Instance/Family.hs view
@@ -61,6 +61,7 @@ import Data.Function ( on ) import qualified GHC.LanguageExtensions as LangExt+import GHC.Unit.Env (unitEnv_hpts) {- Note [The type family instance consistency story] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -293,14 +294,14 @@ -- See Note [The type family instance consistency story]. checkFamInstConsistency :: [Module] -> TcM () checkFamInstConsistency directlyImpMods- = do { (eps, hpt) <- getEpsAndHpt+ = do { (eps, hug) <- getEpsAndHug ; traceTc "checkFamInstConsistency" (ppr directlyImpMods) ; let { -- Fetch the iface of a given module. Must succeed as -- all directly imported modules must already have been loaded. modIface mod =- case lookupIfaceByModule hpt (eps_PIT eps) mod of+ case lookupIfaceByModule hug (eps_PIT eps) mod of Nothing -> panicDoc "FamInst.checkFamInstConsistency"- (ppr mod $$ pprHPT hpt)+ (ppr mod $$ ppr hug) Just iface -> iface -- Which family instance modules were checked for consistency@@ -318,7 +319,8 @@ ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv . md_fam_insts . hm_details ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi)- | hmi <- eltsHpt hpt]+ | hpt <- unitEnv_hpts hug+ , hmi <- eltsHpt hpt ] }
compiler/GHC/Tc/Module.hs view
@@ -272,7 +272,7 @@ ; -- TODO This is a little skeevy; maybe handle a bit more directly let { simplifyImport (L _ idecl) =- ( renameRawPkgQual (hsc_unit_env hsc_env) (ideclPkgQual idecl)+ ( renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName idecl) (ideclPkgQual idecl) , reLoc $ ideclName idecl) } ; raw_sig_imports <- liftIO@@ -375,18 +375,18 @@ = do { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ; ; this_mod <- getModule- ; let { dep_mods :: ModuleNameEnv ModuleNameWithIsBoot- ; dep_mods = imp_direct_dep_mods imports-- -- We want instance declarations from all home-package+ ; gbl_env <- getGblEnv+ ; let { -- We want instance declarations from all home-package -- modules below this one, including boot modules, except -- ourselves. The 'except ourselves' is so that we don't -- get the instances from this module's hs-boot file. This -- filtering also ensures that we don't see instances from -- modules batch (@--make@) compiled before this one, but -- which are not below this one.- ; (home_insts, home_fam_insts) = hptInstancesBelow hsc_env (moduleName this_mod)- (S.fromList (nonDetEltsUFM dep_mods))+ ; (home_insts, home_fam_insts) =++ hptInstancesBelow hsc_env (homeUnitId $ hsc_home_unit hsc_env) (GWIB (moduleName this_mod)(hscSourceToIsBoot (tcg_src gbl_env)))+ } ; -- Record boot-file info in the EPS, so that it's@@ -1790,7 +1790,7 @@ -- See Note [Dealing with main] checkMainType tcg_env = do { hsc_env <- getTopEnv- ; if tcg_mod tcg_env /= mainModIs hsc_env+ ; if tcg_mod tcg_env /= mainModIs (hsc_HUE hsc_env) then return emptyWC else do { rdr_env <- getGlobalRdrEnv@@ -1822,7 +1822,7 @@ ; tcg_env <- getGblEnv ; let dflags = hsc_dflags hsc_env- main_mod = mainModIs hsc_env+ main_mod = mainModIs (hsc_HUE hsc_env) main_occ = getMainOcc dflags exported_mains :: [Name]@@ -2056,7 +2056,7 @@ case i of -- force above: see #15111 IIModule n -> getOrphans n NoPkgQual IIDecl i -> getOrphans (unLoc (ideclName i))- (renameRawPkgQual (hsc_unit_env hsc_env) (ideclPkgQual i))+ (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i)) ; let imports = emptyImportAvails { imp_orphs = orphs@@ -2171,25 +2171,6 @@ global_ids <- mapM (externaliseAndTidyId this_mod) zonked_ids ; -- Note [Interactively-bound Ids in GHCi] in GHC.Driver.Env -{- ---------------------------------------------- At one stage I removed any shadowed bindings from the type_env;- they are inaccessible but might, I suppose, cause a space leak if we leave them there.- However, with Template Haskell they aren't necessarily inaccessible. Consider this- GHCi session- Prelude> let f n = n * 2 :: Int- Prelude> fName <- runQ [| f |]- Prelude> $(return $ AppE fName (LitE (IntegerL 7)))- 14- Prelude> let f n = n * 3 :: Int- Prelude> $(return $ AppE fName (LitE (IntegerL 7)))- In the last line we use 'fName', which resolves to the *first* 'f'- in scope. If we delete it from the type env, GHCi crashes because- it doesn't expect that.-- Hence this code is commented out---------------------------------------------------- -}- traceOptTcRn Opt_D_dump_tc (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids, text "Typechecked expr" <+> ppr zonked_expr]) ;@@ -2972,7 +2953,7 @@ , ppr_fam_insts fam_insts , ppr_rules rules , text "Dependent modules:" <+>- pprUFM (imp_direct_dep_mods imports) (ppr . sort)+ (ppr . sort . installedModuleEnvElts $ imp_direct_dep_mods imports) , text "Dependent packages:" <+> ppr (S.toList $ imp_dep_direct_pkgs imports)] -- The use of sort is just to reduce unnecessary@@ -3090,7 +3071,7 @@ withTcPlugins :: HscEnv -> TcM a -> TcM a withTcPlugins hsc_env m =- case catMaybes $ mapPlugins hsc_env tcPlugin of+ case catMaybes $ mapPlugins (hsc_plugins hsc_env) tcPlugin of [] -> m -- Common fast case plugins -> do ev_binds_var <- newTcEvBinds@@ -3115,7 +3096,7 @@ withDefaultingPlugins :: HscEnv -> TcM a -> TcM a withDefaultingPlugins hsc_env m =- do case catMaybes $ mapPlugins hsc_env defaultingPlugin of+ do case catMaybes $ mapPlugins (hsc_plugins hsc_env) defaultingPlugin of [] -> m -- Common fast case plugins -> do (plugins,stops) <- mapAndUnzipM start_plugin plugins -- This ensures that dePluginStop is called even if a type@@ -3133,7 +3114,7 @@ withHoleFitPlugins :: HscEnv -> TcM a -> TcM a withHoleFitPlugins hsc_env m =- case catMaybes $ mapPlugins hsc_env holeFitPlugin of+ case catMaybes $ mapPlugins (hsc_plugins hsc_env) holeFitPlugin of [] -> m -- Common fast case plugins -> do (plugins,stops) <- mapAndUnzipM start_plugin plugins -- This ensures that hfPluginStop is called even if a type@@ -3155,7 +3136,7 @@ -> TcM (TcGblEnv, HsGroup GhcRn) runRenamerPlugin gbl_env hs_group = do hsc_env <- getTopEnv- withPlugins hsc_env+ withPlugins (hsc_plugins hsc_env) (\p opts (e, g) -> ( mark_plugin_unsafe (hsc_dflags hsc_env) >> renamedResultAction p opts e g)) (gbl_env, hs_group)@@ -3178,7 +3159,7 @@ runTypecheckerPlugin :: ModSummary -> TcGblEnv -> TcM TcGblEnv runTypecheckerPlugin sum gbl_env = do hsc_env <- getTopEnv- withPlugins hsc_env+ withPlugins (hsc_plugins hsc_env) (\p opts env -> mark_plugin_unsafe (hsc_dflags hsc_env) >> typeCheckResultAction p opts sum env) gbl_env
compiler/GHC/Tc/Plugin.hs view
@@ -73,7 +73,6 @@ , EvExpr, EvBindsVar, EvBind, mkGivenEvBind ) import GHC.Types.Var ( EvVar ) -import GHC.Unit.Env import GHC.Unit.Module ( ModuleName, Module ) import GHC.Types.Name ( OccName, Name ) import GHC.Types.TyThing ( TyThing )@@ -81,8 +80,7 @@ import GHC.Core.TyCon ( TyCon ) import GHC.Core.DataCon ( DataCon ) import GHC.Core.Class ( Class )-import GHC.Driver.Config.Finder ( initFinderOpts )-import GHC.Driver.Env ( HscEnv(..), hsc_units )+import GHC.Driver.Env ( HscEnv(..) ) import GHC.Utils.Outputable ( SDoc ) import GHC.Core.Type ( Kind, Type, PredType ) import GHC.Types.Id ( Id )@@ -103,12 +101,7 @@ findImportedModule :: ModuleName -> PkgQual -> TcPluginM Finder.FindResult findImportedModule mod_name mb_pkg = do hsc_env <- getTopEnv- let fc = hsc_FC hsc_env- let mhome_unit = ue_home_unit (hsc_unit_env hsc_env)- let units = hsc_units hsc_env- let dflags = hsc_dflags hsc_env- let fopts = initFinderOpts dflags- tcPluginIO $ Finder.findImportedModule fc fopts units mhome_unit mod_name mb_pkg+ tcPluginIO $ Finder.findImportedModule hsc_env mod_name mb_pkg lookupOrig :: Module -> OccName -> TcPluginM Name lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod
compiler/GHC/Tc/Solver.hs view
@@ -216,7 +216,7 @@ simplifyAndEmitFlatConstraints :: WantedConstraints -> TcM () -- See Note [Failure in local type signatures] simplifyAndEmitFlatConstraints wanted- = do { -- Solve and zonk to esablish the+ = do { -- Solve and zonk to establish the -- preconditions for floatKindEqualities wanted <- runTcSEqualities (solveWanteds wanted) ; wanted <- TcM.zonkWC wanted@@ -2740,7 +2740,7 @@ | otherwise = all is_std_class clss && (any (isNumClass ovl_strings) clss) -- is_std_class adds IsString to the standard numeric classes,- -- when -foverloaded-strings is enabled+ -- when -XOverloadedStrings is enabled is_std_class cls = isStandardClass cls || (ovl_strings && (cls `hasKey` isStringClassKey)) @@ -2792,14 +2792,14 @@ -- ill-kinded defaulting attempts like (Eq []) or (Foldable Int) here. -- In interactive mode, or with -XExtendedDefaultRules,--- we default Show a to Show () to avoid graututious errors on "show []"+-- we default Show a to Show () to avoid gratuitous errors on "show []" isInteractiveClass :: Bool -- -XOverloadedStrings? -> Class -> Bool isInteractiveClass ovl_strings cls = isNumClass ovl_strings cls || (classKey cls `elem` interactiveClassKeys) -- isNumClass adds IsString to the standard numeric classes,- -- when -foverloaded-strings is enabled+ -- when -XOverloadedStrings is enabled isNumClass :: Bool -- -XOverloadedStrings? -> Class -> Bool isNumClass ovl_strings cls
compiler/GHC/Tc/Solver/Canonical.hs view
@@ -46,6 +46,8 @@ import GHC.Types.Name.Set import GHC.Types.Name.Reader import GHC.Hs.Type( HsIPName(..) )+import GHC.Types.Unique ( hasKey )+import GHC.Builtin.Names ( coercibleTyConKey ) import GHC.Data.Pair import GHC.Utils.Misc@@ -537,19 +539,19 @@ -- nor are repeated mk_strict_superclasses rec_clss (CtGiven { ctev_evar = evar, ctev_loc = loc }) tvs theta cls tys- = concatMapM (do_one_given (mk_given_loc loc)) $+ = concatMapM do_one_given $ classSCSelIds cls where dict_ids = mkTemplateLocals theta size = sizeTypes tys - do_one_given given_loc sel_id+ do_one_given sel_id | isUnliftedType sc_pred , not (null tvs && null theta) = -- See Note [Equality superclasses in quantified constraints] return [] | otherwise- = do { given_ev <- newGivenEvVar given_loc $+ = do { given_ev <- newGivenEvVar sc_loc $ mk_given_desc sel_id sc_pred ; mk_superclasses rec_clss given_ev tvs theta sc_pred } where@@ -579,12 +581,19 @@ `App` (evId evar `mkVarApps` (tvs ++ dict_ids)) `mkVarApps` sc_tvs - mk_given_loc loc+ sc_loc | isCTupleClass cls = loc -- For tuple predicates, just take them apart, without -- adding their (large) size into the chain. When we -- get down to a base predicate, we'll include its size. -- #10335++ | isEqPredClass cls+ || cls `hasKey` coercibleTyConKey+ = loc -- The only superclasses of ~, ~~, and Coercible are primitive+ -- equalities, and they don't use the InstSCOrigin mechanism+ -- detailed in Note [Solving superclass constraints] in+ -- GHC.Tc.TyCl.Instance. Skip for a tiny performance win. -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance -- for explantation of InstSCOrigin and Note [Replacement vs keeping] in
compiler/GHC/Tc/Utils/Backpack.hs view
@@ -18,7 +18,6 @@ import GHC.Prelude -import GHC.Driver.Config.Finder import GHC.Driver.Env import GHC.Driver.Ppr import GHC.Driver.Session@@ -41,7 +40,6 @@ import GHC.Types.PkgQual import GHC.Unit-import GHC.Unit.Env import GHC.Unit.Finder import GHC.Unit.Module.Warnings import GHC.Unit.Module.ModIface@@ -307,17 +305,13 @@ implicitRequirements hsc_env normal_imports = fmap concat $ forM normal_imports $ \(mb_pkg, L _ imp) -> do- found <- findImportedModule fc fopts units mhome_unit imp mb_pkg+ found <- findImportedModule hsc_env imp mb_pkg case found of Found _ mod | notHomeModuleMaybe mhome_unit mod -> return (uniqDSetToList (moduleFreeHoles mod)) _ -> return [] where- fc = hsc_FC hsc_env- mhome_unit = ue_home_unit (hsc_unit_env hsc_env)- units = hsc_units hsc_env- dflags = hsc_dflags hsc_env- fopts = initFinderOpts dflags+ mhome_unit = hsc_home_unit_maybe hsc_env -- | Like @implicitRequirements'@, but returns either the module name, if it is -- a free hole, or the instantiated unit the imported module is from, so that@@ -329,15 +323,11 @@ -> IO ([ModuleName], [InstantiatedUnit]) implicitRequirementsShallow hsc_env normal_imports = go ([], []) normal_imports where- fc = hsc_FC hsc_env- mhome_unit = ue_home_unit (hsc_unit_env hsc_env)- units = hsc_units hsc_env- dflags = hsc_dflags hsc_env- fopts = initFinderOpts dflags+ mhome_unit = hsc_home_unit_maybe hsc_env go acc [] = pure acc go (accL, accR) ((mb_pkg, L _ imp):imports) = do- found <- findImportedModule fc fopts units mhome_unit imp mb_pkg+ found <- findImportedModule hsc_env imp mb_pkg let acc' = case found of Found _ mod | notHomeModuleMaybe mhome_unit mod -> case moduleUnit mod of@@ -376,7 +366,7 @@ initTc hsc_env HsigFile -- bogus False- (mainModIs hsc_env)+ (mainModIs (hsc_HUE hsc_env)) (realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0)) -- bogus $ checkUnit uid where@@ -569,12 +559,7 @@ let inner_mod = tcg_semantic_mod tcg_env let mod_name = moduleName (tcg_mod tcg_env) let unit_state = hsc_units hsc_env- let fc = hsc_FC hsc_env- let nc = hsc_NC hsc_env- let mhome_unit = ue_home_unit (hsc_unit_env hsc_env) let dflags = hsc_dflags hsc_env- let logger = hsc_logger hsc_env- let hooks = hsc_hooks hsc_env -- STEP 1: Figure out all of the external signature interfaces -- we are going to merge in.@@ -589,7 +574,7 @@ ctx = initSDocContext dflags defaultUserStyle fmap fst . withException ctx- $ findAndReadIface logger nc fc hooks unit_state mhome_unit dflags+ $ findAndReadIface hsc_env (text "mergeSignatures") im m NotBoot -- STEP 3: Get the unrenamed exports of all these interfaces,@@ -886,8 +871,9 @@ -- supposed to include itself in its dep_orphs/dep_finsts. See #13214 iface' = iface { mi_final_exts = (mi_final_exts iface){ mi_orphan = False, mi_finsts = False } } home_unit = hsc_home_unit hsc_env+ other_home_units = hsc_all_home_unit_ids hsc_env avails = plusImportAvails (tcg_imports tcg_env) $- calculateAvails home_unit iface' False NotBoot ImportedBySystem+ calculateAvails home_unit other_home_units iface' False NotBoot ImportedBySystem return tcg_env { tcg_inst_env = inst_env, tcg_insts = insts,@@ -956,6 +942,7 @@ hsc_env <- getTopEnv let unit_state = hsc_units hsc_env home_unit = hsc_home_unit hsc_env+ other_home_units = hsc_all_home_unit_ids hsc_env addErrCtxt (impl_msg unit_state impl_mod req_mod) $ do let insts = instUnitInsts uid @@ -976,7 +963,7 @@ loadModuleInterfaces (text "Loading orphan modules (from implementor of hsig)") (dep_orphs (mi_deps impl_iface)) - let avails = calculateAvails home_unit+ let avails = calculateAvails home_unit other_home_units impl_iface False{- safe -} NotBoot ImportedBySystem fix_env = mkNameEnv [ (greMangledName rdr_elt, FixItem occ f) | (occ, f) <- mi_fixities impl_iface@@ -1002,14 +989,7 @@ let sig_mod = mkModule (VirtUnit uid) mod_name isig_mod = fst (getModuleInstantiation sig_mod) hsc_env <- getTopEnv- let nc = hsc_NC hsc_env- let fc = hsc_FC hsc_env- let mhome_unit = ue_home_unit (hsc_unit_env hsc_env)- let units = hsc_units hsc_env- let dflags = hsc_dflags hsc_env- let logger = hsc_logger hsc_env- let hooks = hsc_hooks hsc_env- mb_isig_iface <- liftIO $ findAndReadIface logger nc fc hooks units mhome_unit dflags+ mb_isig_iface <- liftIO $ findAndReadIface hsc_env (text "checkImplements 2") isig_mod sig_mod NotBoot isig_iface <- case mb_isig_iface of
compiler/GHC/Tc/Utils/Env.hs view
@@ -106,7 +106,6 @@ import GHC.Unit.Module import GHC.Unit.Home import GHC.Unit.External-import GHC.Unit.Env import GHC.Utils.Outputable import GHC.Utils.Panic@@ -162,7 +161,7 @@ lookupGlobal_maybe hsc_env name = do { -- Try local envt let mod = icInteractiveModule (hsc_IC hsc_env)- mhome_unit = ue_home_unit (hsc_unit_env hsc_env)+ mhome_unit = hsc_home_unit_maybe hsc_env tcg_semantic_mod = homeModuleInstantiation mhome_unit mod ; if nameIsLocalOrFrom tcg_semantic_mod name
compiler/GHC/Tc/Utils/Monad.hs view
@@ -32,7 +32,7 @@ getEpsVar, getEps, updateEps, updateEps_,- getHpt, getEpsAndHpt,+ getHpt, getEpsAndHug, -- * Arrow scopes newArrowScope, escapeArrowScope,@@ -268,7 +268,7 @@ let { -- bangs to avoid leaking the env (#19356) !dflags = hsc_dflags hsc_env ;- !mhome_unit = ue_home_unit (hsc_unit_env hsc_env) ;+ !mhome_unit = hsc_home_unit_maybe hsc_env; !logger = hsc_logger hsc_env ; maybe_rn_syntax :: forall a. a -> Maybe a ;@@ -597,9 +597,9 @@ getHpt :: TcRnIf gbl lcl HomePackageTable getHpt = do { env <- getTopEnv; return (hsc_HPT env) } -getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)-getEpsAndHpt = do { env <- getTopEnv; eps <- liftIO $ hscEPS env- ; return (eps, hsc_HPT env) }+getEpsAndHug :: TcRnIf gbl lcl (ExternalPackageState, HomeUnitGraph)+getEpsAndHug = do { env <- getTopEnv; eps <- liftIO $ hscEPS env+ ; return (eps, hsc_HUG env) } -- | A convenient wrapper for taking a @MaybeErr SDoc a@ and throwing -- an exception if it is an error.@@ -2073,7 +2073,7 @@ = do { tcg_env <- getGblEnv ; hsc_env <- getTopEnv -- bangs to avoid leaking the envs (#19356)- ; let !mhome_unit = ue_home_unit (hsc_unit_env hsc_env)+ ; let !mhome_unit = hsc_home_unit_maybe hsc_env !knot_vars = tcg_type_env_var tcg_env -- When we are instantiating a signature, we DEFINITELY -- do not want to knot tie.
compiler/GHC/Tc/Validity.hs view
@@ -1606,7 +1606,7 @@ Consider the (bogus) instance Eq Char# We elaborate to 'Eq (Char# |> UnivCo(hole))' where the hole is an-insoluble equality constraint for * ~ #. We'll report the insoluble+insoluble equality constraint for Type ~ TYPE WordRep. We'll report the insoluble constraint separately, but we don't want to *also* complain that Eq is not applied to a type constructor. So we look gaily look through CastTys here.
compiler/GHC/ThToHs.hs view
@@ -1119,15 +1119,17 @@ Note [Converting UInfix] ~~~~~~~~~~~~~~~~~~~~~~~~-When converting @UInfixE@, @UInfixP@, and @UInfixT@ values, we want to readjust-the trees to reflect the fixities of the underlying operators:+When converting @UInfixE@, @UInfixP@, @UInfixT@, and @PromotedUInfixT@ values,+we want to readjust the trees to reflect the fixities of the underlying+operators: UInfixE x * (UInfixE y + z) ---> (x * y) + z This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and-@mkHsOpTyRn@ in GHC.Rename.HsType), which expects that the input will be completely-right-biased for types and left-biased for everything else. So we left-bias the-trees of @UInfixP@ and @UInfixE@ and right-bias the trees of @UInfixT@.+@mkHsOpTyRn@ in GHC.Rename.HsType), which expects that the input will be+completely right-biased for types and left-biased for everything else. So we+left-bias the trees of @UInfixP@ and @UInfixE@ and right-bias the trees of+@UInfixT@ and @PromotedUnfixT@. Sample input: @@ -1603,11 +1605,28 @@ } UInfixT t1 s t2- -> do { t2' <- cvtType t2- ; t <- cvtOpAppT t1 s t2'+ -> do { s' <- tconNameN s+ ; t2' <- cvtType t2+ ; t <- cvtOpAppT t1 s' t2' ; mk_apps (unLoc t) tys' } -- Note [Converting UInfix] + PromotedInfixT t1 s t2+ -> do { s' <- cName s+ ; t1' <- cvtType t1+ ; t2' <- cvtType t2+ ; mk_apps+ (HsTyVar noAnn IsPromoted (noLocA s'))+ ([HsValArg t1', HsValArg t2'] ++ tys')+ }++ PromotedUInfixT t1 s t2+ -> do { s' <- cNameN s+ ; t2' <- cvtType t2+ ; t <- cvtOpAppT t1 s' t2'+ ; mk_apps (unLoc t) tys'+ } -- Note [Converting UInfix]+ ParensT t -> do { t' <- cvtType t ; mk_apps (HsParTy noAnn t') tys'@@ -1769,14 +1788,18 @@ See the @cvtOpApp@ documentation for how this function works. -}-cvtOpAppT :: TH.Type -> TH.Name -> LHsType GhcPs -> CvtM (LHsType GhcPs)+cvtOpAppT :: TH.Type -> LocatedN RdrName -> LHsType GhcPs -> CvtM (LHsType GhcPs) cvtOpAppT (UInfixT x op2 y) op1 z- = do { l <- cvtOpAppT y op1 z- ; cvtOpAppT x op2 l }+ = do { op2' <- tconNameN op2+ ; l <- cvtOpAppT y op1 z+ ; cvtOpAppT x op2' l }+cvtOpAppT (PromotedUInfixT x op2 y) op1 z+ = do { op2' <- cNameN op2+ ; l <- cvtOpAppT y op1 z+ ; cvtOpAppT x op2' l } cvtOpAppT x op y- = do { op' <- tconNameN op- ; x' <- cvtType x- ; returnLA (mkHsOpTy x' op' y) }+ = do { x' <- cvtType x+ ; returnLA (mkHsOpTy x' op y) } cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs) cvtKind = cvtTypeKind "kind"
compiler/GHC/Unit/Finder.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiWayIf #-} -- | Module finder module GHC.Unit.Finder (@@ -24,6 +25,7 @@ mkHiOnlyModLocation, mkHiPath, mkObjPath,+ addModuleToFinder, addHomeModuleToFinder, uncacheModule, mkStubPaths,@@ -41,6 +43,7 @@ import GHC.Builtin.Names ( gHC_PRIM ) +import GHC.Unit.Env import GHC.Unit.Types import GHC.Unit.Module import GHC.Unit.Home@@ -64,7 +67,10 @@ import Control.Monad import Data.Time import qualified Data.Map as M-+import GHC.Driver.Env+ ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env) )+import GHC.Driver.Config.Finder+import qualified Data.Set as Set type FileExt = String -- Filename extension type BaseName = String -- Basename of file@@ -90,12 +96,12 @@ -- remove all the home modules from the cache; package modules are -- assumed to not move around during a session; also flush the file hash -- cache-flushFinderCaches :: FinderCache -> HomeUnit -> IO ()-flushFinderCaches (FinderCache ref file_ref) home_unit = do+flushFinderCaches :: FinderCache -> UnitEnv -> IO ()+flushFinderCaches (FinderCache ref file_ref) ue = do atomicModifyIORef' ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ()) atomicModifyIORef' file_ref $ \_ -> (M.empty, ()) where- is_ext mod _ = not (isHomeInstalledModule home_unit mod)+ is_ext mod _ = not (isUnitEnvInstalledModule ue mod) addToFinderCache :: FinderCache -> InstalledModule -> InstalledFindResult -> IO () addToFinderCache (FinderCache ref _) key val =@@ -130,32 +136,66 @@ -- packages to find the module, if a package is specified then only -- that package is searched for the module. -findImportedModule+findImportedModule :: HscEnv -> ModuleName -> PkgQual -> IO FindResult+findImportedModule hsc_env mod fs =+ let fc = hsc_FC hsc_env+ mhome_unit = hsc_home_unit_maybe hsc_env+ dflags = hsc_dflags hsc_env+ fopts = initFinderOpts dflags+ in do+ findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod fs++findImportedModuleNoHsc :: FinderCache -> FinderOpts- -> UnitState+ -> UnitEnv -> Maybe HomeUnit -> ModuleName -> PkgQual -> IO FindResult-findImportedModule fc fopts units mhome_unit mod_name mb_pkg =+findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = case mb_pkg of NoPkgQual -> unqual_import- ThisPkg _ -> home_import+ ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import+ | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os)+ | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts)) OtherPkg _ -> pkg_import where- home_import- | Just home_unit <- mhome_unit- = findHomeModule fc fopts home_unit mod_name- | otherwise- = pure $ NoPackage (panic "findImportedModule: no home-unit")+ all_opts = case mhome_unit of+ Nothing -> other_fopts+ Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts - pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg - unqual_import = home_import+ home_import = case mhome_unit of+ Just home_unit -> findHomeModule fc fopts home_unit mod_name+ Nothing -> pure $ NoPackage (panic "findImportedModule: no home-unit")+++ home_pkg_import (uid, opts)+ -- If the module is reexported, then look for it as if it was from the perspective+ -- of that package which reexports it.+ | mod_name `Set.member` finder_reexportedModules opts =+ findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual+ | mod_name `Set.member` finder_hiddenModules opts =+ return (mkHomeHidden uid)+ | otherwise =+ findHomePackageModule fc opts uid mod_name++ any_home_import = foldr orIfNotFound home_import (map home_pkg_import other_fopts)++ pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg++ unqual_import = any_home_import `orIfNotFound` findExposedPackageModule fc fopts units mod_name NoPkgQual + units = case mhome_unit of+ Nothing -> ue_units ue+ Just home_unit -> homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue+ hpt_deps :: [UnitId]+ hpt_deps = homeUnitDepends units+ other_fopts = map (\uid -> (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))) hpt_deps+ -- | Locate a plugin module requested by the user, for a compiler -- plugin. This consults the same set of exposed packages as -- 'findImportedModule', unless @-hide-all-plugin-packages@ or@@ -174,12 +214,14 @@ -- reading the interface for a module mentioned by another interface, -- for example (a "system import"). -findExactModule :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IO InstalledFindResult-findExactModule fc fopts unit_state mhome_unit mod = do+findExactModule :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IO InstalledFindResult+findExactModule fc fopts other_fopts unit_state mhome_unit mod = do case mhome_unit of Just home_unit- | isHomeInstalledModule home_unit mod- -> findInstalledHomeModule fc fopts home_unit (moduleName mod)+ | isHomeInstalledModule home_unit mod+ -> findInstalledHomeModule fc fopts (homeUnitId home_unit) (moduleName mod)+ | Just home_fopts <- unitEnv_lookup_maybe (moduleUnit mod) other_fopts+ -> findInstalledHomeModule fc home_fopts (moduleUnit mod) (moduleName mod) _ -> findPackageModule fc unit_state fopts mod -- -----------------------------------------------------------------------------@@ -215,9 +257,9 @@ -- been done. Otherwise, do the lookup (with the IO action) and save -- the result in the finder cache and the module location cache (if it -- was successful.)-homeSearchCache :: FinderCache -> HomeUnit -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult+homeSearchCache :: FinderCache -> UnitId -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult homeSearchCache fc home_unit mod_name do_this = do- let mod = mkHomeInstalledModule home_unit mod_name+ let mod = mkModule home_unit mod_name modLocationCache fc mod do_this findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult@@ -285,6 +327,11 @@ addToFinderCache fc mod result return result +addModuleToFinder :: FinderCache -> Module -> ModLocation -> IO ()+addModuleToFinder fc mod loc = do+ let imod = toUnitId <$> mod+ addToFinderCache fc imod (InstalledFound loc imod)+ -- This returns a module because it's more convenient for users addHomeModuleToFinder :: FinderCache -> HomeUnit -> ModuleName -> ModLocation -> IO Module addHomeModuleToFinder fc home_unit mod_name loc = do@@ -303,7 +350,7 @@ findHomeModule :: FinderCache -> FinderOpts -> HomeUnit -> ModuleName -> IO FindResult findHomeModule fc fopts home_unit mod_name = do let uid = homeUnitAsUnit home_unit- r <- findInstalledHomeModule fc fopts home_unit mod_name+ r <- findInstalledHomeModule fc fopts (homeUnitId home_unit) mod_name return $ case r of InstalledFound loc _ -> Found loc (mkHomeModule home_unit mod_name) InstalledNoPackage _ -> NoPackage uid -- impossible@@ -316,6 +363,32 @@ fr_suggestions = [] } +mkHomeHidden :: UnitId -> FindResult+mkHomeHidden uid =+ NotFound { fr_paths = []+ , fr_pkg = Just (RealUnit (Definite uid))+ , fr_mods_hidden = [RealUnit (Definite uid)]+ , fr_pkgs_hidden = []+ , fr_unusables = []+ , fr_suggestions = []}++findHomePackageModule :: FinderCache -> FinderOpts -> UnitId -> ModuleName -> IO FindResult+findHomePackageModule fc fopts home_unit mod_name = do+ let uid = RealUnit (Definite home_unit)+ r <- findInstalledHomeModule fc fopts home_unit mod_name+ return $ case r of+ InstalledFound loc _ -> Found loc (mkModule uid mod_name)+ InstalledNoPackage _ -> NoPackage uid -- impossible+ InstalledNotFound fps _ -> NotFound {+ fr_paths = fps,+ fr_pkg = Just uid,+ fr_mods_hidden = [],+ fr_pkgs_hidden = [],+ fr_unusables = [],+ fr_suggestions = []+ }++ -- | Implements the search for a module name in the home package only. Calling -- this function directly is usually *not* what you want; currently, it's used -- as a building block for the following operations:@@ -332,13 +405,16 @@ -- -- 4. Some special-case code in GHCi (ToDo: Figure out why that needs to -- call this.)-findInstalledHomeModule :: FinderCache -> FinderOpts -> HomeUnit -> ModuleName -> IO InstalledFindResult+findInstalledHomeModule :: FinderCache -> FinderOpts -> UnitId -> ModuleName -> IO InstalledFindResult findInstalledHomeModule fc fopts home_unit mod_name = do homeSearchCache fc home_unit mod_name $ let- home_path = finder_importPaths fopts+ maybe_working_dir = finder_workingDirectory fopts+ home_path = case maybe_working_dir of+ Nothing -> finder_importPaths fopts+ Just fp -> augmentImports fp (finder_importPaths fopts) hisuf = finder_hiSuf fopts- mod = mkHomeInstalledModule home_unit mod_name+ mod = mkModule home_unit mod_name source_exts = [ ("hs", mkHomeModLocationSearched fopts mod_name "hs")@@ -367,6 +443,11 @@ then return (InstalledFound (error "GHC.Prim ModLocation") mod) else searchPathExts home_path mod exts +-- | Prepend the working directory to the search path.+augmentImports :: FilePath -> [FilePath] -> [FilePath]+augmentImports _work_dir [] = []+augmentImports work_dir (fp:fps) | isAbsolute fp = fp : augmentImports work_dir fps+ | otherwise = (work_dir </> fp) : augmentImports work_dir fps -- | Search for a module in external packages only. findPackageModule :: FinderCache -> UnitState -> FinderOpts -> InstalledModule -> IO InstalledFindResult
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-version: 0.20211201+version: 0.20220103 license: BSD3 license-file: LICENSE category: Development@@ -82,7 +82,7 @@ process >= 1 && < 1.7, rts, hpc == 0.6.*,- ghc-lib-parser == 0.20211201,+ ghc-lib-parser == 0.20220103, stm build-tools: alex >= 3.1, happy >= 1.19.4 other-extensions:@@ -153,7 +153,6 @@ GHC.Cmm.Switch, GHC.Cmm.Type, GHC.CmmToAsm.CFG.Weight,- GHC.CmmToAsm.Config, GHC.Core, GHC.Core.Class, GHC.Core.Coercion,@@ -283,6 +282,7 @@ GHC.LanguageExtensions, GHC.LanguageExtensions.Type, GHC.Lexeme,+ GHC.Linker.Static.Utils, GHC.Linker.Types, GHC.Parser, GHC.Parser.Annotation,@@ -477,6 +477,7 @@ GHC.ByteCode.Linker GHC.Cmm.CallConv GHC.Cmm.CommonBlockElim+ GHC.Cmm.Config GHC.Cmm.ContFlowOpt GHC.Cmm.Dataflow GHC.Cmm.DebugBlock@@ -511,6 +512,7 @@ GHC.CmmToAsm.CFG GHC.CmmToAsm.CFG.Dominators GHC.CmmToAsm.CPrim+ GHC.CmmToAsm.Config GHC.CmmToAsm.Dwarf GHC.CmmToAsm.Dwarf.Constants GHC.CmmToAsm.Dwarf.Types@@ -581,6 +583,7 @@ GHC.CmmToLlvm GHC.CmmToLlvm.Base GHC.CmmToLlvm.CodeGen+ GHC.CmmToLlvm.Config GHC.CmmToLlvm.Data GHC.CmmToLlvm.Mangler GHC.CmmToLlvm.Ppr@@ -616,7 +619,9 @@ GHC.Data.UnionFind GHC.Driver.Backpack GHC.Driver.CodeOutput+ GHC.Driver.Config.Cmm GHC.Driver.Config.CmmToAsm+ GHC.Driver.Config.CmmToLlvm GHC.Driver.Config.Finder GHC.Driver.GenerateCgIPEStub GHC.Driver.Main
ghc-lib/stage0/lib/llvm-targets view
@@ -53,5 +53,7 @@ ,("armv6-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align")) ,("armv7-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+strict-align")) ,("aarch64-unknown-netbsd", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))+,("x86_64-unknown-openbsd", ("e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "+retpoline-indirect-calls +retpoline-indirect-branches"))+,("i386-unknown-openbsd", ("e-m:e-p:32:32-p270:32:32-p271:32:32-p272:64:64-f64:32:64-f80:32-n8:16:32-S128", "i586", "")) ,("arm-unknown-nto-qnx-eabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm7tdmi", "+strict-align")) ]
libraries/ghci/GHCi/TH.hs view
@@ -194,6 +194,7 @@ qReifyModule m = ghcCmd (ReifyModule m) qReifyConStrictness name = ghcCmd (ReifyConStrictness name) qLocation = fromMaybe noLoc . qsLocation <$> getState+ qGetPackageRoot = ghcCmd GetPackageRoot qAddDependentFile file = ghcCmd (AddDependentFile file) qAddTempFile suffix = ghcCmd (AddTempFile suffix) qAddTopDecls decls = ghcCmd (AddTopDecls decls)
libraries/template-haskell/Language/Haskell/TH/CodeDo.hs view
@@ -1,7 +1,9 @@ -- | This module exists to work nicely with the QualifiedDo -- extension.+-- -- @ -- import qualified Language.Haskell.TH.CodeDo as Code+-- -- myExample :: Monad m => Code m a -> Code m a -> Code m a -- myExample opt1 opt2 = -- Code.do