diff --git a/compiler/GHC.hs b/compiler/GHC.hs --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -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 diff --git a/compiler/GHC/Cmm/Config.hs b/compiler/GHC/Cmm/Config.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Cmm/Config.hs @@ -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 + diff --git a/compiler/GHC/Cmm/Dataflow.hs b/compiler/GHC/Cmm/Dataflow.hs --- a/compiler/GHC/Cmm/Dataflow.hs +++ b/compiler/GHC/Cmm/Dataflow.hs @@ -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 diff --git a/compiler/GHC/Cmm/Info/Build.hs b/compiler/GHC/Cmm/Info/Build.hs --- a/compiler/GHC/Cmm/Info/Build.hs +++ b/compiler/GHC/Cmm/Info/Build.hs @@ -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. diff --git a/compiler/GHC/Cmm/LayoutStack.hs b/compiler/GHC/Cmm/LayoutStack.hs --- a/compiler/GHC/Cmm/LayoutStack.hs +++ b/compiler/GHC/Cmm/LayoutStack.hs @@ -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 diff --git a/compiler/GHC/Cmm/Lint.hs b/compiler/GHC/Cmm/Lint.hs --- a/compiler/GHC/Cmm/Lint.hs +++ b/compiler/GHC/Cmm/Lint.hs @@ -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 diff --git a/compiler/GHC/Cmm/Opt.hs b/compiler/GHC/Cmm/Opt.hs --- a/compiler/GHC/Cmm/Opt.hs +++ b/compiler/GHC/Cmm/Opt.hs @@ -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 diff --git a/compiler/GHC/Cmm/Pipeline.hs b/compiler/GHC/Cmm/Pipeline.hs --- a/compiler/GHC/Cmm/Pipeline.hs +++ b/compiler/GHC/Cmm/Pipeline.hs @@ -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 diff --git a/compiler/GHC/Cmm/Sink.hs b/compiler/GHC/Cmm/Sink.hs --- a/compiler/GHC/Cmm/Sink.hs +++ b/compiler/GHC/Cmm/Sink.hs @@ -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 diff --git a/compiler/GHC/Cmm/Switch/Implement.hs b/compiler/GHC/Cmm/Switch/Implement.hs --- a/compiler/GHC/Cmm/Switch/Implement.hs +++ b/compiler/GHC/Cmm/Switch/Implement.hs @@ -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' diff --git a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs --- a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs @@ -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 <- x -- compute x <- y -- x, x, x - (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 <- x + -- compute x <- y + -- x, x, x + (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 + => MO_Add - 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 , we'd need to ldr x0, x0 still, which -- for the first case can be optimized to use ldr x0, [x0, #:lo12:] --- 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 diff --git a/compiler/GHC/CmmToAsm/AArch64/Instr.hs b/compiler/GHC/CmmToAsm/AArch64/Instr.hs --- a/compiler/GHC/CmmToAsm/AArch64/Instr.hs +++ b/compiler/GHC/CmmToAsm/AArch64/Instr.hs @@ -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 diff --git a/compiler/GHC/CmmToAsm/AArch64/Ppr.hs b/compiler/GHC/CmmToAsm/AArch64/Ppr.hs --- a/compiler/GHC/CmmToAsm/AArch64/Ppr.hs +++ b/compiler/GHC/CmmToAsm/AArch64/Ppr.hs @@ -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 diff --git a/compiler/GHC/CmmToAsm/CFG.hs b/compiler/GHC/CmmToAsm/CFG.hs --- a/compiler/GHC/CmmToAsm/CFG.hs +++ b/compiler/GHC/CmmToAsm/CFG.hs @@ -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 diff --git a/compiler/GHC/CmmToAsm/Config.hs b/compiler/GHC/CmmToAsm/Config.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/CmmToAsm/Config.hs @@ -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 diff --git a/compiler/GHC/CmmToAsm/PIC.hs b/compiler/GHC/CmmToAsm/PIC.hs --- a/compiler/GHC/CmmToAsm/PIC.hs +++ b/compiler/GHC/CmmToAsm/PIC.hs @@ -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 diff --git a/compiler/GHC/CmmToAsm/PPC/Instr.hs b/compiler/GHC/CmmToAsm/PPC/Instr.hs --- a/compiler/GHC/CmmToAsm/PPC/Instr.hs +++ b/compiler/GHC/CmmToAsm/PPC/Instr.hs @@ -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 diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs --- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs @@ -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 diff --git a/compiler/GHC/CmmToAsm/X86/Instr.hs b/compiler/GHC/CmmToAsm/X86/Instr.hs --- a/compiler/GHC/CmmToAsm/X86/Instr.hs +++ b/compiler/GHC/CmmToAsm/X86/Instr.hs @@ -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 diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs --- a/compiler/GHC/CmmToC.hs +++ b/compiler/GHC/CmmToC.hs @@ -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 diff --git a/compiler/GHC/CmmToLlvm.hs b/compiler/GHC/CmmToLlvm.hs --- a/compiler/GHC/CmmToLlvm.hs +++ b/compiler/GHC/CmmToLlvm.hs @@ -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], []) diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs --- a/compiler/GHC/CmmToLlvm/Base.hs +++ b/compiler/GHC/CmmToLlvm/Base.hs @@ -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) -- ---------------------------------------------------------------------------- diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs --- a/compiler/GHC/CmmToLlvm/CodeGen.hs +++ b/compiler/GHC/CmmToLlvm/CodeGen.hs @@ -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. diff --git a/compiler/GHC/CmmToLlvm/Config.hs b/compiler/GHC/CmmToLlvm/Config.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/CmmToLlvm/Config.hs @@ -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. + } diff --git a/compiler/GHC/CmmToLlvm/Data.hs b/compiler/GHC/CmmToLlvm/Data.hs --- a/compiler/GHC/CmmToLlvm/Data.hs +++ b/compiler/GHC/CmmToLlvm/Data.hs @@ -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 diff --git a/compiler/GHC/CmmToLlvm/Ppr.hs b/compiler/GHC/CmmToLlvm/Ppr.hs --- a/compiler/GHC/CmmToLlvm/Ppr.hs +++ b/compiler/GHC/CmmToLlvm/Ppr.hs @@ -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 diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -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 diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs --- a/compiler/GHC/Core/Opt/SetLevels.hs +++ b/compiler/GHC/Core/Opt/SetLevels.hs @@ -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 diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -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 ) diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -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 diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -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] diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -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 diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -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. diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -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 {- ************************************************************************ diff --git a/compiler/GHC/Driver/Config/Cmm.hs b/compiler/GHC/Driver/Config/Cmm.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Driver/Config/Cmm.hs @@ -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 diff --git a/compiler/GHC/Driver/Config/CmmToAsm.hs b/compiler/GHC/Driver/Config/CmmToAsm.hs --- a/compiler/GHC/Driver/Config/CmmToAsm.hs +++ b/compiler/GHC/Driver/Config/CmmToAsm.hs @@ -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 diff --git a/compiler/GHC/Driver/Config/CmmToLlvm.hs b/compiler/GHC/Driver/Config/CmmToLlvm.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Driver/Config/CmmToLlvm.hs @@ -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 + } diff --git a/compiler/GHC/Driver/Config/Finder.hs b/compiler/GHC/Driver/Config/Finder.hs --- a/compiler/GHC/Driver/Config/Finder.hs +++ b/compiler/GHC/Driver/Config/Finder.hs @@ -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 diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -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 diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -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 "") - - -- 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 "") + + -- 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 "") + -- 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. diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs --- a/compiler/GHC/Driver/MakeFile.hs +++ b/compiler/GHC/Driver/MakeFile.hs @@ -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)) $$ diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -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 diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs --- a/compiler/GHC/Driver/Pipeline/Execute.hs +++ b/compiler/GHC/Driver/Pipeline/Execute.hs @@ -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 -> diff --git a/compiler/GHC/Driver/Pipeline/LogQueue.hs b/compiler/GHC/Driver/Pipeline/LogQueue.hs --- a/compiler/GHC/Driver/Pipeline/LogQueue.hs +++ b/compiler/GHC/Driver/Pipeline/LogQueue.hs @@ -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)) diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -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) diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -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]) diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -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`. diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -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. diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs --- a/compiler/GHC/HsToCore/Usage.hs +++ b/compiler/GHC/HsToCore/Usage.hs @@ -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 diff --git a/compiler/GHC/Iface/Errors.hs b/compiler/GHC/Iface/Errors.hs --- a/compiler/GHC/Iface/Errors.hs +++ b/compiler/GHC/Iface/Errors.hs @@ -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 diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -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] diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -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) diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -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 diff --git a/compiler/GHC/Iface/Recomp/Flags.hs b/compiler/GHC/Iface/Recomp/Flags.hs --- a/compiler/GHC/Iface/Recomp/Flags.hs +++ b/compiler/GHC/Iface/Recomp/Flags.hs @@ -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 diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -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) --} diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -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 diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs --- a/compiler/GHC/Linker/Loader.hs +++ b/compiler/GHC/Linker/Loader.hs @@ -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 diff --git a/compiler/GHC/Linker/Static.hs b/compiler/GHC/Linker/Static.hs --- a/compiler/GHC/Linker/Static.hs +++ b/compiler/GHC/Linker/Static.hs @@ -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 diff --git a/compiler/GHC/Llvm.hs b/compiler/GHC/Llvm.hs --- a/compiler/GHC/Llvm.hs +++ b/compiler/GHC/Llvm.hs @@ -10,9 +10,6 @@ -- module GHC.Llvm ( - LlvmOpts (..), - initLlvmOpts, - -- * Modules, Functions and Blocks LlvmModule(..), diff --git a/compiler/GHC/Llvm/Ppr.hs b/compiler/GHC/Llvm/Ppr.hs --- a/compiler/GHC/Llvm/Ppr.hs +++ b/compiler/GHC/Llvm/Ppr.hs @@ -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 diff --git a/compiler/GHC/Llvm/Types.hs b/compiler/GHC/Llvm/Types.hs --- a/compiler/GHC/Llvm/Types.hs +++ b/compiler/GHC/Llvm/Types.hs @@ -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) diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -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 diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -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 diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -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 -> diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs --- a/compiler/GHC/Runtime/Heap/Inspect.hs +++ b/compiler/GHC/Runtime/Heap/Inspect.hs @@ -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) diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs --- a/compiler/GHC/Runtime/Loader.hs +++ b/compiler/GHC/Runtime/Loader.hs @@ -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 diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -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 diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs --- a/compiler/GHC/StgToCmm/Ticky.hs +++ b/compiler/GHC/StgToCmm/Ticky.hs @@ -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' diff --git a/compiler/GHC/SysTools/Tasks.hs b/compiler/GHC/SysTools/Tasks.hs --- a/compiler/GHC/SysTools/Tasks.hs +++ b/compiler/GHC/SysTools/Tasks.hs @@ -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 diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs --- a/compiler/GHC/Tc/Gen/App.hs +++ b/compiler/GHC/Tc/Gen/App.hs @@ -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! diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs --- a/compiler/GHC/Tc/Gen/Export.hs +++ b/compiler/GHC/Tc/Gen/Export.hs @@ -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 diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -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 diff --git a/compiler/GHC/Tc/Instance/Family.hs b/compiler/GHC/Tc/Instance/Family.hs --- a/compiler/GHC/Tc/Instance/Family.hs +++ b/compiler/GHC/Tc/Instance/Family.hs @@ -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 ] } diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -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 diff --git a/compiler/GHC/Tc/Plugin.hs b/compiler/GHC/Tc/Plugin.hs --- a/compiler/GHC/Tc/Plugin.hs +++ b/compiler/GHC/Tc/Plugin.hs @@ -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 diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs --- a/compiler/GHC/Tc/Solver.hs +++ b/compiler/GHC/Tc/Solver.hs @@ -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 diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs --- a/compiler/GHC/Tc/Solver/Canonical.hs +++ b/compiler/GHC/Tc/Solver/Canonical.hs @@ -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 diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -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 diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -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 diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -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. diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs --- a/compiler/GHC/Tc/Validity.hs +++ b/compiler/GHC/Tc/Validity.hs @@ -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. diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -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" diff --git a/compiler/GHC/Unit/Finder.hs b/compiler/GHC/Unit/Finder.hs --- a/compiler/GHC/Unit/Finder.hs +++ b/compiler/GHC/Unit/Finder.hs @@ -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 diff --git a/ghc-lib.cabal b/ghc-lib.cabal --- a/ghc-lib.cabal +++ b/ghc-lib.cabal @@ -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 diff --git a/ghc-lib/stage0/lib/llvm-targets b/ghc-lib/stage0/lib/llvm-targets --- a/ghc-lib/stage0/lib/llvm-targets +++ b/ghc-lib/stage0/lib/llvm-targets @@ -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")) ] diff --git a/libraries/ghci/GHCi/TH.hs b/libraries/ghci/GHCi/TH.hs --- a/libraries/ghci/GHCi/TH.hs +++ b/libraries/ghci/GHCi/TH.hs @@ -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) diff --git a/libraries/template-haskell/Language/Haskell/TH/CodeDo.hs b/libraries/template-haskell/Language/Haskell/TH/CodeDo.hs --- a/libraries/template-haskell/Language/Haskell/TH/CodeDo.hs +++ b/libraries/template-haskell/Language/Haskell/TH/CodeDo.hs @@ -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