Downsweep.hs

{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ViewPatterns #-}
module GHC.Driver.Downsweep
  ( downsweep
  , downsweepThunk
  , downsweepInstalledModules
  , downsweepFromRootNodes
  , downsweepInteractiveImports
  , DownsweepMode(..)
   -- * Summary functions
  , summariseModule
  , summariseFile
  , summariseModuleInterface
  , SummariseResult(..)
  -- * Helper functions
  , instantiationNodes
  , checkHomeUnitsClosed
  ) where

import GHC.Prelude

import GHC.Platform.Ways

import GHC.Driver.Config.Finder (initFinderOpts)
import GHC.Driver.Config.Parser (initParserOpts)
import GHC.Driver.DynFlags
import GHC.Driver.Phases
import {-# SOURCE #-} GHC.Driver.Pipeline (preprocess)
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.Messager
import GHC.Driver.MakeSem
import GHC.Driver.MakeAction
import GHC.Driver.Config.Diagnostic
import GHC.Driver.Ppr

import GHC.Iface.Load

import GHC.Parser.Header
import GHC.Rename.Names
import GHC.Tc.Utils.Backpack
import GHC.Runtime.Context

import Language.Haskell.Syntax.ImpExp

import GHC.Data.Graph.Directed
import GHC.Data.FastString
import GHC.Data.Maybe      ( expectJust )
import qualified GHC.Data.Maybe as M
import GHC.Data.OsPath     ( unsafeEncodeUtf )
import GHC.Data.StringBuffer
import GHC.Data.Graph.Directed.Reachability
import qualified GHC.LanguageExtensions as LangExt

import GHC.Utils.Exception ( throwIO, SomeAsyncException )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Error
import GHC.Utils.Logger
import GHC.Utils.Fingerprint
import GHC.Utils.TmpFs
import GHC.Utils.Constants

import GHC.Types.Error
import GHC.Types.Target
import GHC.Types.SourceFile
import GHC.Types.SourceError
import GHC.Types.SrcLoc
import GHC.Types.Unique.Map
import GHC.Types.PkgQual
import GHC.Types.Basic


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.Graph
import GHC.Unit.Module.Deps
import qualified GHC.Unit.Home.Graph as HUG
import GHC.Unit.Module.Stage

import Data.Either ( rights, partitionEithers, lefts )
import qualified Data.Map as Map
import qualified Data.Set as Set

import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )
import qualified Control.Monad.Catch as MC
import Data.Maybe
import Data.List (partition)
import Data.Time
import Data.List (unfoldr)
import Data.Bifunctor (first, bimap)
import System.Directory
import System.FilePath

import Control.Monad.Trans.Reader
import qualified Data.Map.Strict as M
import Control.Monad.Trans.Class
import System.IO.Unsafe (unsafeInterleaveIO)

{-
Note [Downsweep and the ModuleGraph]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

The ModuleGraph stores the relationship between all the modules, units, and
instantiations in the current session.

When we do downsweep, we build up a new ModuleGraph, starting from the root
modules. By following all the dependencies we construct a graph which allows
us to answer questions about the transitive closure of the imports.

The module graph is accessible in the HscEnv.

When is this graph constructed?

1. In `--make` mode, we construct the graph before starting to do any compilation.

2. In `-c` (oneshot) mode, we construct the graph when we have calculated the
   ModSummary for the module we are compiling. The `ModuleGraph` is stored in a
   thunk, so it is only constructed when it is needed. This avoids reading
   the interface files of the whole transitive closure unless they are needed.

3. In some situations (such as loading plugins) we may need to construct the
   graph without having a ModSummary. In this case we use the `downsweepInstalledModules`
   function.

The result is having a uniform graph available for the whole compilation pipeline.

-}

-- 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 ModuleNodeInfo]

-----------------------------------------------------------------------------
--
-- | Downsweep (dependency analysis) for --make mode
--
-- 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 ModuleGraph 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.
--
-- This function is intendned for use by --make mode and will also insert
-- LinkNodes and InstantiationNodes for any home units.
--
-- It will also turn on code generation for any modules that need it by calling
-- 'enableCodeGenForTH'.
downsweep :: HscEnv
          -> (GhcMessage -> AnyGhcDiagnostic)
          -> Maybe Messager
          -> [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], ModuleGraph)
                -- 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 diag_wrapper msg old_summaries excl_mods allow_dup_roots = do
  n_jobs <- mkWorkerLimit (hsc_dflags hsc_env)
  (root_errs, root_summaries) <- rootSummariesParallel n_jobs hsc_env diag_wrapper msg summary
  let closure_errs = checkHomeUnitsClosed unit_env
      unit_env = hsc_unit_env hsc_env

      all_errs = closure_errs ++ root_errs

  case all_errs of
    [] -> do
       (downsweep_errs, downsweep_nodes) <- downsweepFromRootNodes hsc_env old_summary_map excl_mods allow_dup_roots DownsweepUseCompile (map ModuleNodeCompile root_summaries) []

       let (other_errs, unit_nodes) = partitionEithers $ HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env)

       let all_nodes = downsweep_nodes ++ unit_nodes
       let all_errs = downsweep_errs ++ other_errs

       let logger = hsc_logger hsc_env
           tmpfs = hsc_tmpfs hsc_env
       -- 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_configured_nodes <- enableCodeGenForTH logger tmpfs unit_env all_nodes

       return (all_errs, th_configured_nodes)
    _  -> return (all_errs, emptyMG)
  where
    summary = getRootSummary excl_mods old_summary_map

    -- A cache from file paths to the already summarised modules. The same file
    -- can be used in multiple units so the map is also keyed by which unit the
    -- file was used in.
    -- Reuse these if we can because the most expensive part of downsweep is
    -- reading the headers.
    old_summary_map :: M.Map (UnitId, FilePath) ModSummary
    old_summary_map =
      M.fromList [((ms_unitid ms, msHsFilePath ms), ms) | ms <- old_summaries]

    -- Dependencies arising on a unit (backpack and module linking deps)
    unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode]
    unitModuleNodes summaries uid hue =
      maybeToList (linkNodes summaries uid hue)

-- | Calculate the module graph starting from a single ModSummary. The result is a
-- thunk, which when forced will perform the downsweep. This is useful in oneshot
-- mode where the module graph may never be needed.
-- If downsweep fails, then the resulting errors are just thrown.
downsweepThunk :: HscEnv -> ModSummary -> IO ModuleGraph
downsweepThunk hsc_env mod_summary = unsafeInterleaveIO $ do
  debugTraceMsg (hsc_logger hsc_env) 3 $ text "Computing Module Graph thunk..."
  ~(errs, mg) <- downsweepFromRootNodes hsc_env mempty [] True DownsweepUseFixed [ModuleNodeCompile mod_summary] []
  let dflags = hsc_dflags hsc_env
  liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env)
                                   (initPrintConfig dflags)
                                   (initDiagOpts dflags)
                                   (GhcDriverMessage <$> unionManyMessages errs)
  return (mkModuleGraph mg)

-- | Construct a module graph starting from the interactive context.
-- Produces, a thunk, which when forced will perform the downsweep.
-- This graph contains the current interactive module, and its dependencies.
--
--  Invariant: The hsc_mod_graph already contains the relevant home modules which
--  might be imported by the interactive imports.
--
-- This is a first approximation for this function. There probably should also
-- be edges linking the interactive modules together. (Ie Ghci7 importing Ghci6
-- and so on)
-- See Note [runTcInteractive module graph]
downsweepInteractiveImports :: HscEnv -> InteractiveContext -> IO ModuleGraph
downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do
  debugTraceMsg (hsc_logger hsc_env) 3 $ (text "Computing Interactive Module Graph thunk...")
  let imps = ic_imports (hsc_IC hsc_env)

  let interactive_mn = icInteractiveModule ic
  -- No sensible value for ModLocation.. if you hit this panic then you probably
  -- need to add proper support for modules without any source files to the driver.
  let ml = pprPanic "modLocation" (ppr interactive_mn <+> ppr imps)
  let key = moduleToMnk interactive_mn NotBoot
  let node_type = ModuleNodeFixed key ml

  -- The existing nodes in the module graph. This will be populated when GHCi runs
  -- :load. Any home package modules need to already be in here.
  let cached_nodes = Map.fromList [ (mkNodeKey n, n) | n <- mg_mss (hsc_mod_graph hsc_env) ]

  (module_edges, graph) <- loopFromInteractive hsc_env (map mkEdge imps) cached_nodes
  let interactive_node = ModuleNode module_edges node_type

  let all_nodes  = M.elems graph
  return $ mkModuleGraph (interactive_node : all_nodes)

  where
 --
    mkEdge :: InteractiveImport -> Either ModuleNodeEdge (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))
    -- A simple edge to a module from the same home unit
    mkEdge (IIModule n) =
      let
        mod_node_key = ModNodeKeyWithUid
          { mnkModuleName = GWIB (moduleName n) NotBoot
          , mnkUnitId =
              -- 'toUnitId' is safe here, as we can't import modules that
              -- don't have a 'UnitId'.
              toUnitId (moduleUnit n)
          }
        mod_node_edge =
          ModuleNodeEdge NormalLevel (NodeKey_Module mod_node_key)
      in Left mod_node_edge
    -- A complete import statement
    mkEdge (IIDecl i) =
      let lvl = convImportLevel (ideclLevelSpec i)
          wanted_mod = unLoc (ideclName i)
          is_boot = ideclSource i
          mb_pkg = renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i)
          unitId = homeUnitId $ hsc_home_unit hsc_env
      in Right (unitId, lvl, mb_pkg, GWIB (noLoc wanted_mod) is_boot)

loopFromInteractive :: HscEnv
                    -> [Either ModuleNodeEdge (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]
                    -> M.Map NodeKey ModuleGraphNode
                    -> IO ([ModuleNodeEdge],M.Map NodeKey ModuleGraphNode)
loopFromInteractive _ [] cached_nodes = return ([], cached_nodes)
loopFromInteractive hsc_env (edge:edges) cached_nodes =
  case edge of
    Left edge -> do
        (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes
        return (edge : edges, cached_nodes')
    Right (unitId, lvl, mb_pkg, GWIB wanted_mod is_boot) -> do
      let home_unit = ue_unitHomeUnit unitId (hsc_unit_env hsc_env)
      let k _ loc mod =
            let key = moduleToMnk mod is_boot
            in return $ FoundHome (ModuleNodeFixed key loc)
      found <- liftIO $ summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg []
      case found of
        -- Case 1: Home modules have to already be in the cache.
        FoundHome (ModuleNodeFixed mod _) -> do
          let edge = ModuleNodeEdge lvl (NodeKey_Module mod)
          -- Note: Does not perform any further downsweep as the module must already be in the cache.
          (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes
          return (edge : edges, cached_nodes')
        -- Case 2: External units may not be in the cache, if we haven't already initialised the
        -- module graph. We can construct the module graph for those here by calling loopUnit.
        External uid -> do
          let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env
              cached_nodes' = loopUnit hsc_env' cached_nodes [uid]
              edge = ModuleNodeEdge lvl (NodeKey_ExternalUnit uid)
          (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes'
          return (edge : edges, cached_nodes')
        -- And if it's not found.. just carry on and hope.
        _ -> loopFromInteractive hsc_env edges cached_nodes


-- | Create a module graph from a list of installed modules.
-- This is used by the loader when we need to load modules but there
-- isn't already an existing module graph. For example, when loading plugins
-- during initialisation.
--
-- If you call this function, then if the `Module` you request to downsweep can't
-- be found then this function will throw errors.
-- If you need to use this function elsewhere, then it would make sense to make it
-- return [DriverMessages] and [ModuleGraph] so that the caller can handle the errors as it sees fit.
-- At the moment, it is overfitted for what `get_reachable_nodes` needs.
downsweepInstalledModules :: HscEnv -> [Module] -> IO ModuleGraph
downsweepInstalledModules hsc_env mods = do
    let
        (home_mods, external_mods) = partition (\u -> moduleUnitId u `elem` hsc_all_home_unit_ids hsc_env) mods
        installed_mods = map (fst . getModuleInstantiation) home_mods
        external_uids = map moduleUnitId external_mods

        process :: InstalledModule -> IO ModuleNodeInfo
        process i = do
          res <- findExactModule hsc_env i NotBoot
          case res of
            InstalledFound loc -> return $ ModuleNodeFixed (installedModuleToMnk i) loc
            -- It is an internal-ish error if this happens, since we any call to this function should
            -- already know that we can find the modules we need to load.
            _ -> throwGhcException $ ProgramError $ showSDoc (hsc_dflags hsc_env) $ text "downsweepInstalledModules: Could not find installed module" <+> ppr i

    nodes <- mapM process installed_mods
    (errs, mg) <- downsweepFromRootNodes hsc_env mempty [] True DownsweepUseFixed nodes external_uids

    -- Similarly here, we should really not get any errors, but print them out if we do.
    let dflags = hsc_dflags hsc_env
    liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env)
                                     (initPrintConfig dflags)
                                     (initDiagOpts dflags)
                                     (GhcDriverMessage <$> unionManyMessages errs)

    return (mkModuleGraph mg)



-- | Whether downsweep should use compiler or fixed nodes. Compile nodes are used
-- by --make mode, and fixed nodes by oneshot mode.
--
-- See Note [Module Types in the ModuleGraph] for the difference between the two.
data DownsweepMode = DownsweepUseCompile | DownsweepUseFixed

-- | Perform downsweep, starting from the given root 'ModuleNodeInfo's and root
-- 'UnitId's.
-- This function will start at the given roots, and traverse downwards to find
-- all the dependencies, all the way to the leaf units.
downsweepFromRootNodes :: HscEnv
                  -> M.Map (UnitId, FilePath) ModSummary
                  -> [ModuleName]
                  -> Bool
                  -> DownsweepMode -- ^ Whether to create fixed or compile nodes for dependencies
                  -> [ModuleNodeInfo] -- ^ The starting ModuleNodeInfo
                  -> [UnitId] -- ^ The starting units
                  -> IO ([DriverMessages], [ModuleGraphNode])
downsweepFromRootNodes hsc_env old_summaries excl_mods allow_dup_roots mode root_nodes root_uids
   = do
       let root_map = mkRootMap root_nodes
       checkDuplicates root_map
       let env = DownsweepEnv hsc_env mode old_summaries excl_mods
       (deps', map0) <- runDownsweepM env  $ do
                    (module_deps, map0) <- loopModuleNodeInfos root_nodes (M.empty, root_map)
                    let all_deps = loopUnit hsc_env module_deps root_uids
                    let all_instantiations =  getHomeUnitInstantiations hsc_env
                    deps' <- loopInstantiations all_instantiations all_deps
                    return (deps', map0)


       let downsweep_errs = lefts $ concat $ M.elems map0
           downsweep_nodes = M.elems deps'

       return (downsweep_errs, downsweep_nodes)
     where
        getHomeUnitInstantiations :: HscEnv -> [(UnitId, InstantiatedUnit)]
        getHomeUnitInstantiations hsc_env = HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++  instantiationNodes uid (homeUnitEnv_units hue)) [] (hsc_HUG hsc_env)

        -- 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
           | not allow_dup_roots
           , dup_root:_ <- dup_roots = liftIO $ multiRootsErr dup_root
           | otherwise = pure ()
           where
             dup_roots :: [[ModuleNodeInfo]]        -- Each at least of length 2
             dup_roots = filterOut isSingleton $ map rights (M.elems root_map)


calcDeps :: ModSummary -> [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]
calcDeps ms =
  -- Add a dependency on the HsBoot file if it exists
  -- This gets passed to the loopImports function which just ignores it if it
  -- can't be found.
  [(ms_unitid ms, NormalLevel, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++
  [(ms_unitid ms, lvl, b, c) | (lvl, b, c) <- msDeps ms ]


type DownsweepM a = ReaderT DownsweepEnv IO a
data DownsweepEnv = DownsweepEnv {
      downsweep_hsc_env :: HscEnv
    , _downsweep_mode :: DownsweepMode
    , _downsweep_old_summaries :: M.Map (UnitId, FilePath) ModSummary
    , _downsweep_excl_mods :: [ModuleName]
}

runDownsweepM :: DownsweepEnv -> DownsweepM a -> IO a
runDownsweepM env act = runReaderT act env


loopInstantiations :: [(UnitId, InstantiatedUnit)]
                   -> M.Map NodeKey ModuleGraphNode
                   -> DownsweepM (M.Map NodeKey ModuleGraphNode)
loopInstantiations [] done = pure done
loopInstantiations ((home_uid, iud) :xs) done = do
  hsc_env <- asks downsweep_hsc_env
  let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
  let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env
      done' = loopUnit hsc_env' done [instUnitInstanceOf iud]
      payload = InstantiationNode home_uid iud
  loopInstantiations xs (M.insert (mkNodeKey payload) payload done')


-- 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,
            DownsweepCache)
      -> DownsweepM ((M.Map NodeKey ModuleGraphNode), DownsweepCache)
loopSummaries [] done = pure done
loopSummaries (ms:next) (done, summarised)
  | Just {} <- M.lookup k done
  = loopSummaries next (done, summarised)
  -- Didn't work out what the imports mean yet, now do that.
  | otherwise = do
     (final_deps, done', summarised') <- loopImports (calcDeps ms) done summarised
     -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.
     (_, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised'
     loopSummaries next (M.insert k (ModuleNode final_deps (ModuleNodeCompile ms)) done'', summarised'')
  where
    k = NodeKey_Module (msKey ms)

    hs_file_for_boot
      | HsBootFile <- ms_hsc_src ms
      = Just $ ((ms_unitid ms), NormalLevel, NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot))
      | otherwise
      = Nothing

loopModuleNodeInfos :: [ModuleNodeInfo] -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache)
loopModuleNodeInfos is cache = foldM (flip loopModuleNodeInfo) cache is

loopModuleNodeInfo :: ModuleNodeInfo -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache)
loopModuleNodeInfo mod_node_info (done, summarised) = do
  case mod_node_info of
    ModuleNodeCompile ms -> do
      loopSummaries [ms] (done, summarised)
    ModuleNodeFixed mod ml -> do
      done' <- loopFixedModule mod ml done
      return (done', summarised)

-- NB: loopFixedModule does not take a downsweep cache, because if you
-- ever reach a Fixed node, everything under that also must be fixed.
loopFixedModule :: ModNodeKeyWithUid -> ModLocation
                -> M.Map NodeKey ModuleGraphNode
                -> DownsweepM (M.Map NodeKey ModuleGraphNode)
loopFixedModule key loc done = do
  let nk = NodeKey_Module key
  hsc_env <- asks downsweep_hsc_env
  case M.lookup nk done of
    Just {} -> return done
    Nothing -> do
      -- MP: TODO, we should just read the dependency info from the interface rather than either
      -- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory)
      -- b. Loading the whole interface into a buffer before discarding it. (wasted allocation and deserialisation)
      read_result <- liftIO $
        -- 1. Check if the interface is already loaded into the EPS by some other
        -- part of the compiler.
        lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case
          Just iface -> return (M.Succeeded iface)
          Nothing -> readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc)
      case read_result of
        M.Succeeded iface -> do
          -- Computer information about this node
          let node_deps = ifaceDeps (mi_deps iface)
              edges = map mkFixedEdge node_deps
              node = ModuleNode edges (ModuleNodeFixed key loc)
          foldM (loopFixedNodeKey (mnkUnitId key)) (M.insert nk node done) (bimap snd snd <$> node_deps)
        -- Ignore any failure, we might try to read a .hi-boot file for
        -- example, even if there is not one.
        M.Failed {} ->
          return done

loopFixedNodeKey :: UnitId -> M.Map NodeKey ModuleGraphNode -> Either ModNodeKeyWithUid UnitId -> DownsweepM  (M.Map NodeKey ModuleGraphNode)
loopFixedNodeKey _ done (Left key) = do
  loopFixedImports [key] done
loopFixedNodeKey home_uid done (Right uid) = do
  -- Set active unit so that looking loopUnit finds the correct
  -- -package flags in the unit state.
  hsc_env <- asks downsweep_hsc_env
  let hsc_env' = hscSetActiveUnitId home_uid hsc_env
  return $ loopUnit hsc_env' done [uid]

mkFixedEdge :: Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId) -> ModuleNodeEdge
mkFixedEdge (Left (lvl, key)) = mkModuleEdge lvl (NodeKey_Module key)
mkFixedEdge (Right (lvl, uid)) = mkModuleEdge lvl (NodeKey_ExternalUnit uid)

ifaceDeps :: Dependencies -> [Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId)]
ifaceDeps deps =
  [ Left (tcImportLevel lvl, ModNodeKeyWithUid dep uid)
  | (lvl, uid, dep) <- Set.toList (dep_direct_mods deps)
  ] ++
  [ Right (tcImportLevel lvl, uid)
  | (lvl, uid) <- Set.toList (dep_direct_pkgs deps)
  ]

-- Like loopImports, but we already know exactly which module we are looking for.
loopFixedImports :: [ModNodeKeyWithUid]
                 -> M.Map NodeKey ModuleGraphNode
                 -> DownsweepM (M.Map NodeKey ModuleGraphNode)
loopFixedImports [] done = pure done
loopFixedImports (key:keys) done = do
  let nk = NodeKey_Module key
  hsc_env <- asks downsweep_hsc_env
  case M.lookup nk done of
    Just {} -> loopFixedImports keys done
    Nothing -> do
      read_result <- liftIO $ findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key)
      case read_result of
        InstalledFound loc -> do
          done' <- loopFixedModule key loc done
          loopFixedImports keys done'
        _otherwise ->
          -- If the finder fails, just keep going, there will be another
          -- error later.
          loopFixedImports keys done

downsweepSummarise :: HomeUnit
                   -> IsBootInterface
                   -> Located ModuleName
                   -> PkgQual
                   -> Maybe (StringBuffer, UTCTime)
                   -> DownsweepM SummariseResult
downsweepSummarise home_unit is_boot wanted_mod mb_pkg maybe_buf = do
  DownsweepEnv hsc_env mode old_summaries excl_mods <- ask
  case mode of
    DownsweepUseCompile -> liftIO $ summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods
    DownsweepUseFixed -> liftIO $ summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods


-- 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, ImportLevel, 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
     -> DownsweepM ([ModuleNodeEdge],
          M.Map NodeKey ModuleGraphNode, DownsweepCache)
                -- The result is the completed NodeMap
loopImports [] done summarised = return ([], done, summarised)
loopImports ((home_uid, imp, mb_pkg, gwib) : ss) done summarised
  | Just summs <- M.lookup cache_key summarised
  = case summs of
      [Right ms] -> do
        let nk = mkModuleEdge imp (NodeKey_Module (mnKey ms))
        (rest, summarised', done') <- loopImports ss done summarised
        return (nk: rest, summarised', done')
      [Left _err] ->
        loopImports ss done summarised
      _errs ->  do
        loopImports ss done summarised
  | otherwise
  = do
       hsc_env <- asks downsweep_hsc_env
       let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
       mb_s <- downsweepSummarise home_unit
                               is_boot wanted_mod mb_pkg
                               Nothing
       case mb_s of
           NotThere -> loopImports ss done summarised
           External uid -> do
            -- Pass an updated hsc_env to loopUnit, as each unit might
            -- have a different visible package database.
            let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env
            let done' = loopUnit hsc_env' done [uid]
            (other_deps, done'', summarised') <- loopImports ss done' summarised
            return (mkModuleEdge imp (NodeKey_ExternalUnit uid) : other_deps, done'', summarised')
           FoundInstantiation iud -> do
            (other_deps, done', summarised') <- loopImports ss done summarised
            return (mkModuleEdge imp (NodeKey_Unit iud) : other_deps, done', summarised')
           FoundHomeWithError (_uid, e) ->  loopImports ss done (Map.insert cache_key [(Left e)] summarised)
           FoundHome s -> do
             (done', summarised') <-
               loopModuleNodeInfo s (done, Map.insert cache_key [Right s] summarised)
             (other_deps, final_done, final_summarised) <- loopImports ss done' summarised'

             -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now.
             return (mkModuleEdge imp (NodeKey_Module (mnKey s)) : other_deps, final_done, final_summarised)
  where
    cache_key = (home_uid, mb_pkg, unLoc <$> gwib)
    GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib
    wanted_mod = L loc mod

loopUnit :: HscEnv -> Map.Map NodeKey ModuleGraphNode -> [UnitId] -> Map.Map NodeKey ModuleGraphNode
loopUnit _ cache [] = cache
loopUnit lcl_hsc_env cache (u:uxs) = do
   let nk = (NodeKey_ExternalUnit u)
   case Map.lookup nk cache of
     Just {} -> loopUnit lcl_hsc_env cache uxs
     Nothing -> case unitDepends <$> lookupUnitId (hsc_units lcl_hsc_env) u of
                 Just us -> loopUnit lcl_hsc_env (loopUnit lcl_hsc_env (Map.insert nk (UnitNode us u) cache) us) uxs
                 Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr u)

multiRootsErr :: [ModuleNodeInfo] -> IO ()
multiRootsErr [] = panic "multiRootsErr"
multiRootsErr summs@(summ1:_)
  = throwOneError $ fmap GhcDriverMessage $
    mkPlainErrorMsgEnvelope noSrcSpan $ DriverDuplicatedModuleDeclaration mod files
  where
    mod = moduleNodeInfoModule summ1
    files = mapMaybe (ml_hs_file . moduleNodeInfoLocation) summs

moduleNotFoundErr :: UnitId -> ModuleName -> DriverMessages
moduleNotFoundErr uid mod = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverModuleNotFound uid mod)

-- | 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.
instantiationNodes :: UnitId -> UnitState -> [(UnitId, InstantiatedUnit)]
instantiationNodes uid unit_state = map (uid,) iuids_to_check
  where
    iuids_to_check :: [InstantiatedUnit]
    iuids_to_check =
      nubSort $ concatMap (goUnitId . fst) (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) . mgNodeUnitId) 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 | isExecutableLink (ghcLink dflags) && isJust ofile && not do_linking ->
            Just (Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverRedirectedNoMain $ mainModuleNameIs dflags))
        -- This should be an error, not a warning (#10895).
        | ghcLink dflags /= NoLink, do_linking -> Just (Right (LinkNode unit_nodes uid))
        | otherwise  -> Nothing

getRootSummary ::
  [ModuleName] ->
  M.Map (UnitId, FilePath) ModSummary ->
  HscEnv ->
  Target ->
  IO (Either DriverMessages ModSummary)
getRootSummary excl_mods old_summary_map hsc_env target
  | TargetFile file mb_phase <- targetId
  = do
    let offset_file = augmentByWorkingDirectory dflags file
    exists <- liftIO $ doesFileExist offset_file
    if exists || isJust maybe_buf
    then summariseFile hsc_env home_unit old_summary_map offset_file mb_phase
         maybe_buf
    else
      return $ Left $ singleMessage $
      mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound offset_file)
  | TargetModule modl <- targetId
  = do
    maybe_summary <- summariseModule hsc_env home_unit old_summary_map NotBoot
                     (L rootLoc modl) (ThisPkg (homeUnitId home_unit))
                     maybe_buf excl_mods
    pure case maybe_summary of
      FoundHome (ModuleNodeCompile s)  -> Right s
      FoundHomeWithError err -> Left (snd err)
      _ -> Left (moduleNotFoundErr uid modl)
    where
      Target {targetId, targetContents = maybe_buf, targetUnitId = uid} = target
      home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env)
      rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
      dflags = homeUnitEnv_dflags (ue_findHomeUnitEnv uid (hsc_unit_env hsc_env))

-- | Execute 'getRootSummary' for the 'Target's using the parallelism pipeline
-- system.
-- Create bundles of 'Target's wrapped in a 'MakeAction' that uses
-- 'withAbstractSem' to wait for a free slot, limiting the number of
-- concurrently computed summaries to the value of the @-j@ option or the slots
-- allocated by the job server, if that is used.
--
-- The 'MakeAction' returns 'Maybe', which is not handled as an error, because
-- 'runLoop' only sets it to 'Nothing' when an exception was thrown, so the
-- result won't be read anyway here.
--
-- To emulate the current behavior, we funnel exceptions past the concurrency
-- barrier and rethrow the first one afterwards.
rootSummariesParallel ::
  WorkerLimit ->
  HscEnv ->
  (GhcMessage -> AnyGhcDiagnostic) ->
  Maybe Messager ->
  (HscEnv -> Target -> IO (Either DriverMessages ModSummary)) ->
  IO ([DriverMessages], [ModSummary])
rootSummariesParallel n_jobs hsc_env diag_wrapper msg get_summary = do
  (actions, get_results) <- unzip <$> mapM action_and_result (zip [1..] bundles)
  runPipelines n_jobs hsc_env diag_wrapper msg actions
  (sequence . catMaybes <$> sequence get_results) >>= \case
    Right results -> pure (partitionEithers (concat results))
    Left exc -> throwIO exc
  where
    bundles = mk_bundles targets

    mk_bundles = unfoldr \case
      [] -> Nothing
      ts -> Just (splitAt bundle_size ts)

    bundle_size = 20

    targets = hsc_targets hsc_env

    action_and_result (log_queue_id, ts) = do
      res_var <- liftIO newEmptyMVar
      pure $! (MakeAction (action log_queue_id ts) res_var, readMVar res_var)

    action log_queue_id target_bundle = do
      env@MakeEnv {compile_sem} <- ask
      lift $ lift $
        withAbstractSem compile_sem $
        withLoggerHsc log_queue_id env \ lcl_hsc_env ->
          MC.try (mapM (get_summary lcl_hsc_env) target_bundle) >>= \case
            Left e | Just (_ :: SomeAsyncException) <- fromException e ->
              throwIO e
            a -> pure a

-- | 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.
--
-- See Note [Multiple Home Units], section 'Closure Property'.
checkHomeUnitsClosed ::  UnitEnv -> [DriverMessages]
checkHomeUnitsClosed ue
    | Set.null bad_unit_ids = []
    | otherwise = [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)]
  where
    home_id_set = HUG.allUnits $ ue_home_unit_graph ue
    bad_unit_ids = upwards_closure Set.\\ home_id_set {- Remove all home units reached, keep only bad nodes -}
    rootLoc = mkGeneralSrcSpan (fsLit "<command line>")

    downwards_closure :: Graph (Node UnitId UnitId)
    downwards_closure = graphFromEdgedVerticesUniq graphNodes

    inverse_closure = graphReachability $ transposeG downwards_closure

    upwards_closure = Set.fromList $ map node_key $ allReachableMany inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set]

    all_unit_direct_deps :: UniqMap UnitId (Set.Set UnitId)
    all_unit_direct_deps
      = HUG.unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue
      where
        go rest this this_uis =
           plusUniqMap_C Set.union
             (addToUniqMap_C Set.union external_depends this (Set.fromList $ this_deps))
             rest
           where
             external_depends = mapUniqMap (Set.fromList . unitDepends) (unitInfoMap this_units)
             this_units = homeUnitEnv_units this_uis
             this_deps = [ toUnitId unit | (unit,Just _) <- explicitUnits this_units]

    graphNodes :: [Node UnitId UnitId]
    graphNodes = go Set.empty home_id_set
      where
        go done todo
          = case Set.minView todo of
              Nothing -> []
              Just (uid, todo')
                | Set.member uid done -> go done todo'
                | otherwise -> case lookupUniqMap all_unit_direct_deps uid of
                    Nothing -> pprPanic "uid not found" (ppr (uid, all_unit_direct_deps))
                    Just depends ->
                      let todo'' = (depends Set.\\ done) `Set.union` todo'
                      in DigraphNode uid uid (Set.toList depends) : go (Set.insert uid done) todo''

-- | Update the every ModSummary that is depended on
-- by a module that needs template haskell. We enable codegen to
-- 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 ModuleGraph
enableCodeGenForTH logger tmpfs unit_env =
  enableCodeGenWhen logger tmpfs TFL_CurrentModule TFL_GhcSession unit_env


data CodeGenEnable = EnableByteCode | EnableObject | EnableByteCodeAndObject deriving (Eq, Show, Ord)

instance Outputable CodeGenEnable where
  ppr = text . show

-- | 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
  -> TempFileLifetime
  -> TempFileLifetime
  -> UnitEnv
  -> [ModuleGraphNode]
  -> IO ModuleGraph
enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = do
  mgMapM enable_code_gen mg
  where
    defaultBackendOf ms = platformDefaultBackend (targetPlatform $ ue_unitFlags (ms_unitid ms) unit_env)

    enable_code_gen :: ModuleNodeInfo -> IO ModuleNodeInfo
    enable_code_gen (ModuleNodeCompile ms) = ModuleNodeCompile <$> enable_code_gen_ms ms
    enable_code_gen m@(ModuleNodeFixed {}) = return m

    -- FIXME: Strong resemblance and some duplication between this and `makeDynFlagsConsistent`.
    -- It would be good to consider how to make these checks more uniform and not duplicated.
    enable_code_gen_ms :: ModSummary -> IO ModSummary
    enable_code_gen_ms ms
      | ModSummary
        { ms_location = ms_location
        , ms_hsc_src = HsSrcFile
        , ms_hspp_opts = dflags
        } <- ms
      , Just enable_spec <- needs_codegen_map ms =
      if | nocode_enable ms -> 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 (unsafeEncodeUtf tn, unsafeEncodeUtf 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_ospath ms_location, ml_dyn_hi_file_ospath ms_location)
                               , (ml_obj_file_ospath ms_location, ml_dyn_obj_file_ospath ms_location))
                   else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags))
                            <*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags))
               let new_dflags = case enable_spec of
                                  EnableByteCode -> dflags { backend = interpreterBackend }
                                  EnableObject   -> dflags { backend = defaultBackendOf ms }
                                  EnableByteCodeAndObject -> (gopt_set dflags Opt_ByteCodeAndObjectCode) { backend = defaultBackendOf ms}
               let ms' = ms
                     { ms_location =
                         ms_location { ml_hi_file_ospath = hi_file
                                     , ml_obj_file_ospath = o_file
                                     , ml_dyn_hi_file_ospath = dyn_hi_file
                                     , ml_dyn_obj_file_ospath = dyn_o_file }
                     , ms_hspp_opts = updOptLevel 0 $ new_dflags
                     }
               -- Recursive call to catch the other cases
               enable_code_gen_ms ms'

         -- If -fprefer-byte-code then satisfy dependency by enabling bytecode (if normal object not enough)
         -- we only get to this case if the default backend is already generating object files, but we need dynamic
         -- objects
         | bytecode_and_enable enable_spec ms -> do
               let ms' = ms
                     { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ByteCodeAndObjectCode
                     }
               -- Recursive call to catch the other cases
               enable_code_gen_ms ms'
         -- Note: dynamic_too_enable case removed - -dynamic-too is deprecated
         | ext_interp_enable ms -> do
               let ms' = ms
                     { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ExternalInterpreter
                     }
               -- Recursive call to catch the other cases
               enable_code_gen_ms ms'

         | needs_full_ways dflags -> do
               let ms' = ms { ms_hspp_opts = set_full_ways dflags }
               -- Recursive call to catch the other cases
               enable_code_gen_ms ms'

         | otherwise -> return ms

    enable_code_gen_ms ms = return ms

    nocode_enable ms@(ModSummary { ms_hspp_opts = dflags }) =
      not (backendGeneratesCode (backend dflags)) &&
      -- 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)

    -- bytecode_and_enable: prefer bytecode over needing dynamic objects
    -- Note: dynamic_too_enable logic removed - -dynamic-too is deprecated
    bytecode_and_enable enable_spec ms =
        prefer_bytecode && not generate_both
      where
        lcl_dflags   = ms_hspp_opts ms
        prefer_bytecode = case enable_spec of
                            EnableByteCodeAndObject -> True
                            EnableByteCode -> True
                            EnableObject -> False

        generate_both   = gopt Opt_ByteCodeAndObjectCode lcl_dflags

    -- #16331 - when no "internal interpreter" is available but we
    -- need to process some TemplateHaskell or QuasiQuotes, we automatically
    -- turn on -fexternal-interpreter.
    ext_interp_enable ms = not ghciSupported && internalInterpreter
      where
       lcl_dflags   = ms_hspp_opts ms
       internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags)


    mg = mkModuleGraph mod_graph

    (td_map, lookup_node) = mkStageDeps mod_graph

    queryReachable ns = isReachableMany td_map (mapMaybe lookup_node ns)

    -- NB: Do not inline these, it is very important to share them across all calls
    -- to needs_obj_set and needs_bc_set.
    !query_obj =
      let !deps = queryReachable need_obj_set
      in \k -> deps (expectJust $ lookup_node k)

    !query_bc  =
      let !deps = queryReachable need_bc_set
      in \k -> deps (expectJust $ lookup_node k)

    -- The direct dependencies of modules which require object code
    need_obj_set =

        -- Note we don't need object code for a module if it uses TemplateHaskell itself. Only
        -- it's dependencies.
        [ (mkNodeKey m, RunStage)
        | m@(ModuleNode _deps (ModuleNodeCompile ms)) <- mod_graph
        , isTemplateHaskellOrQQNonBoot ms
        , not (gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms))
        ]

    -- The direct dependencies of modules which require byte code
    need_bc_set =
        [ (mkNodeKey m, RunStage)
        | m@(ModuleNode _deps (ModuleNodeCompile ms)) <- mod_graph
        , isTemplateHaskellOrQQNonBoot ms
        , gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms)
        ]

    needs_obj_set, needs_bc_set :: ModNodeKeyWithUid -> Bool
    needs_obj_set k = query_obj (NodeKey_Module k, CompileStage)

    needs_bc_set k = query_bc  (NodeKey_Module k, CompileStage)

    -- A map which tells us how to enable code generation for a NodeKey
    needs_codegen_map :: ModSummary -> Maybe CodeGenEnable
    needs_codegen_map ms =
      let nk = msKey ms


      -- Another option here would be to just produce object code, rather than both object and
      -- byte code
      in case (needs_obj_set nk, needs_bc_set nk) of
        (True, True)   -> Just EnableByteCodeAndObject
        (True, False)  -> Just EnableObject
        (False, True)  -> Just EnableByteCode
        (False, False) -> Nothing

    -- FIXME: Duplicated from makeDynFlagsConsistent
    needs_full_ways dflags
      = ghcLink dflags == LinkInMemory &&
        not (gopt Opt_ExternalInterpreter dflags) &&
        targetWays_ dflags /= hostFullWays
    set_full_ways dflags =
        let platform = targetPlatform dflags
            dflags_a = dflags { targetWays_ = hostFullWays }
            dflags_b = foldl gopt_set dflags_a
                     $ concatMap (wayGeneralFlags platform)
                                 hostFullWays
            dflags_c = foldl gopt_unset dflags_b
                     $ concatMap (wayUnsetGeneralFlags platform)
                                 hostFullWays
        in dflags_c

{- 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, there would be no need for -fwrite-interface as it
would 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 the generated code depends on whether `-fprefer-byte-code` is enabled
or not in the module which needs the code generation. If the module requires byte-code then
dependencies will generate byte-code, otherwise they will generate object files.
In the case where some modules require byte-code and some object files, both are
generated by enabling `-fbyte-code-and-object-code`, the test "fat015" tests these
configurations.

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.

Explicit Level Imports
~~~~~~~~~~~~~~~~~~~~~~
When `-XExplicitLevelImports` is enabled, code is only generated for modules
needed for the compile stage. The ReachabilityIndex created by `mkStageDeps` answers
the question, if I compile a module for a specific stage, then which modules at
other stages do I need. The roots of this query are the modules which use `TemplateHaskell`
at the runtime stage, and modules we need code generation for are those which
are needed at the compile time stage. All the logic about how ExplicitLevelImports
and TemplateHaskell affect the needed stages of a module is encoded in mkStageDeps.

Potential TODOS:
~~~~~
* Remove -fwrite-interface and have interface files always written in -fno-code
  mode
* All .o files are now dynamic-capable (-dynamic-too is deprecated), so only
  .o files are generated for template haskell. (The needed way is 'hostFullWays')
* 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.
-}

-- | Populate the Downsweep cache with the root modules.
mkRootMap
  :: [ModuleNodeInfo]
  -> DownsweepCache
mkRootMap summaries = Map.fromListWith (flip (++))
  [ ((moduleNodeInfoUnitId s, NoPkgQual, moduleNodeInfoMnwib 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 (UnitId, 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,
   | Just old_summary <- M.lookup (homeUnitId home_unit, 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)
            (basename, extension) = splitExtension src_fn

            hsc_src
              | isHaskellSigSuffix (drop 1 extension) = HsigFile
              | isHaskellBootSuffix (drop 1 extension) = HsBootFile
              | otherwise = HsSrcFile

            -- Make a ModLocation for this file, adding the @-boot@ suffix to
            -- all paths if the original was a boot file.
            location = mkHomeModLocation fopts pi_mod_name (unsafeEncodeUtf basename) (unsafeEncodeUtf extension) hsc_src

        -- 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 hsc_src

        liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary
            { nms_src_fn = src_fn
            , nms_src_hash = src_hash
            , nms_hsc_src = hsc_src
            , 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.
           let fc      = hsc_FC hsc_env
               mod     = ms_mod old_summary
               hsc_src = ms_hsc_src old_summary
           addModuleToFinder fc mod location hsc_src

           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 ModuleNodeInfo
      | External UnitId
      | NotThere

-- | summariseModule finds the location of the source file for the given module.
-- This version always returns a ModuleNodeCompile node, it is useful for
-- --make mode.
summariseModule :: HscEnv
                -> HomeUnit
                -> M.Map (UnitId, FilePath) ModSummary
                -> IsBootInterface
                -> Located ModuleName
                -> PkgQual
                -> Maybe (StringBuffer, UTCTime)
                -> [ModuleName]
                -> IO SummariseResult
summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods =
  summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods
  where
    k = summariseModuleWithSource home_unit old_summaries is_boot maybe_buf


-- | Like summariseModule but for interface files that we don't want to compile.
-- This version always returns a ModuleNodeFixed node.
summariseModuleInterface :: HscEnv
                        -> HomeUnit
                        -> IsBootInterface
                        -> Located ModuleName
                        -> PkgQual
                        -> [ModuleName]
                        -> IO SummariseResult
summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods =
  summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods
  where
    k _hsc_env loc mod = do
      -- The finder will return a path to the .hi-boot even if it doesn't actually
      -- exist. So check if it exists first before concluding it's there.
      does_exist <- doesFileExist (ml_hi_file loc)
      if does_exist
        then let key = moduleToMnk mod is_boot
             in return $ FoundHome (ModuleNodeFixed key loc)
        else return NotThere



-- Summarise a module, and pick up source and timestamp.
summariseModuleDispatch
          :: (HscEnv -> ModLocation -> Module -> IO SummariseResult) -- ^ Continuation about how to summarise a home module.
          -> HscEnv
          -> HomeUnit
          -> IsBootInterface    -- True <=> a {-# SOURCE #-} import
          -> Located ModuleName -- Imported module to be summarised
          -> PkgQual
          -> [ModuleName]               -- Modules to exclude
          -> IO SummariseResult


summariseModuleDispatch k hsc_env' home_unit is_boot (L _ wanted_mod) mb_pkg 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'

    find_it :: IO SummariseResult

    find_it = do
        found <- findImportedModuleWithIsBoot hsc_env wanted_mod is_boot mb_pkg
        case found of
             Found location mod
                | moduleUnitId mod `Set.member` hsc_all_home_unit_ids hsc_env ->
                        -- Home package
                         k hsc_env location mod
                | 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)


-- | The continuation to summarise a home module if we want to find the source file
-- for it and potentially compile it.
summariseModuleWithSource
          :: HomeUnit
          -> M.Map (UnitId, FilePath) ModSummary
          -- ^ Map of old summaries
          -> IsBootInterface    -- True <=> a {-# SOURCE #-} import
          -> Maybe (StringBuffer, UTCTime)
          -> HscEnv
          -> ModLocation
          -> Module
          -> IO SummariseResult
summariseModuleWithSource home_unit old_summary_map is_boot maybe_buf hsc_env location mod = do
        -- Adjust location to point to the hs-boot source file,
        -- hi file, object file, when is_boot says so
        let src_fn = expectJust (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
          -- This situation can also happen if we have found the .hs file but the
          -- .hs-boot file doesn't exist.
          Nothing -> return NotThere
          Just h  -> do
            fresult <- new_summary_cache_check location mod src_fn h
            return $ case fresult of
              Left err -> FoundHomeWithError (moduleUnitId mod, err)
              Right ms -> FoundHome (ModuleNodeCompile ms)

  where
    dflags    = hsc_dflags hsc_env
    new_summary_cache_check loc mod src_fn h
      | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), 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 /= moduleName mod) $
                throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc
                       $ DriverFileModuleNameMismatch pi_mod_name (moduleName 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_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_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_textual_imps =
            ((,,) NormalLevel NoPkgQual . noLoc <$> extra_sig_imports) ++
            ((,,) NormalLevel 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  :: [Located ModuleName]
      , pi_theimps  :: [(ImportLevel, PkgQual, Located ModuleName)]
      , 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', 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 (\(sp, pk, lmn@(L _ mn)) -> (sp, rn_pkg_qual mn pk, lmn))
  let pi_srcimps = pi_srcimps'
  let pi_theimps = rn_imps pi_theimps'
  return PreprocessedImports {..}