-- The transition from Int to Word64 for uniques makes functions slightly larger
-- without this GHC option some optimizations fail to fire.
-- See https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10568#note_505751
{-# OPTIONS_GHC -fspec-constr-threshold=10000 #-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}

module GHC.Linker.Deps
  ( LinkDepsOpts (..)
  , LinkDeps (..)
  , getLinkDeps
  )
where

import GHC.Prelude

import GHC.Platform.Ways

import GHC.Runtime.Interpreter

import GHC.Linker.Types

import GHC.Types.SourceFile
import GHC.Types.SrcLoc
import GHC.Types.Unique.DSet
import GHC.Types.Unique.DFM

import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Error

import GHC.Unit.Env
import GHC.Unit.Finder
import GHC.Unit.Module
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.WholeCoreBindings
import GHC.Unit.Module.Deps
import GHC.Unit.Module.Graph
import GHC.Unit.Home.ModInfo

import GHC.Iface.Errors.Types
import GHC.Iface.Errors.Ppr

import GHC.Utils.Misc
import GHC.Unit.Home
import GHC.Data.Maybe

import Control.Monad
import Control.Applicative

import qualified Data.Set as Set
import qualified Data.Map as M
import Data.List (isSuffixOf)

import System.FilePath
import System.Directory


data LinkDepsOpts = LinkDepsOpts
  { LinkDepsOpts -> String
ldObjSuffix   :: !String                        -- ^ Suffix of .o files
  , LinkDepsOpts -> Bool
ldOneShotMode :: !Bool                          -- ^ Is the driver in one-shot mode?
  , LinkDepsOpts -> ModuleGraph
ldModuleGraph :: !ModuleGraph                   -- ^ Module graph
  , LinkDepsOpts -> UnitEnv
ldUnitEnv     :: !UnitEnv                       -- ^ Unit environment
  , LinkDepsOpts -> SDocContext
ldPprOpts     :: !SDocContext                   -- ^ Rendering options for error messages
  , LinkDepsOpts -> FinderCache
ldFinderCache :: !FinderCache                   -- ^ Finder cache
  , LinkDepsOpts -> FinderOpts
ldFinderOpts  :: !FinderOpts                    -- ^ Finder options
  , LinkDepsOpts -> Bool
ldUseByteCode :: !Bool                          -- ^ Use bytecode rather than objects
  , LinkDepsOpts -> DiagnosticOpts IfaceMessage
ldMsgOpts     :: !(DiagnosticOpts IfaceMessage) -- ^ Options for diagnostics
  , LinkDepsOpts -> Ways
ldWays        :: !Ways                          -- ^ Enabled ways
  , LinkDepsOpts
-> SDoc -> Module -> IO (MaybeErr MissingInterfaceError ModIface)
ldLoadIface   :: SDoc -> Module -> IO (MaybeErr MissingInterfaceError ModIface)
                                                    -- ^ Interface loader function
  }

data LinkDeps = LinkDeps
  { LinkDeps -> [Linkable]
ldNeededLinkables :: [Linkable]
  , LinkDeps -> [Linkable]
ldAllLinkables    :: [Linkable]
  , LinkDeps -> [UnitId]
ldUnits           :: [UnitId]
  , LinkDeps -> UniqDSet UnitId
ldNeededUnits     :: UniqDSet UnitId
  }

-- | Find all the packages and linkables that a set of modules depends on
--
-- Return the module and package dependencies for the needed modules.
-- See Note [Object File Dependencies]
--
-- Fails with an IO exception if it can't find enough files
--
getLinkDeps
  :: LinkDepsOpts
  -> Interp
  -> LoaderState
  -> SrcSpan      -- for error messages
  -> [Module]     -- If you need these
  -> IO LinkDeps  -- ... then link these first
getLinkDeps :: LinkDepsOpts
-> Interp -> LoaderState -> SrcSpan -> [Module] -> IO LinkDeps
getLinkDeps LinkDepsOpts
opts Interp
interp LoaderState
pls SrcSpan
span [Module]
mods = do
      -- 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.
      -- So here we check the build tag: if we're building a non-standard way
      -- then we need to find & link object files built the "normal" way.
      maybe_normal_osuf <- LinkDepsOpts -> Interp -> SrcSpan -> IO (Maybe String)
checkNonStdWay LinkDepsOpts
opts Interp
interp SrcSpan
span

      get_link_deps opts pls maybe_normal_osuf span mods


get_link_deps
  :: LinkDepsOpts
  -> LoaderState
  -> Maybe FilePath  -- replace object suffixes?
  -> SrcSpan
  -> [Module]
  -> IO LinkDeps
get_link_deps :: LinkDepsOpts
-> LoaderState
-> Maybe String
-> SrcSpan
-> [Module]
-> IO LinkDeps
get_link_deps LinkDepsOpts
opts LoaderState
pls Maybe String
maybe_normal_osuf SrcSpan
span [Module]
mods = 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) <-
          -- 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 LinkDepsOpts -> Bool
ldOneShotMode LinkDepsOpts
opts
            then [Module]
-> UniqDSet Module
-> UniqDSet UnitId
-> IO ([Module], UniqDSet UnitId)
follow_deps ((Module -> Bool) -> [Module] -> [Module]
forall a. (a -> Bool) -> [a] -> [a]
filterOut Module -> Bool
isInteractiveModule [Module]
mods)
                              UniqDSet Module
forall a. UniqDSet a
emptyUniqDSet UniqDSet UnitId
forall a. UniqDSet a
emptyUniqDSet;
            else do
              (pkgs, mmods) <- [(UniqDSet UnitId, Maybe Module)]
-> ([UniqDSet UnitId], [Maybe Module])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(UniqDSet UnitId, Maybe Module)]
 -> ([UniqDSet UnitId], [Maybe Module]))
-> IO [(UniqDSet UnitId, Maybe Module)]
-> IO ([UniqDSet UnitId], [Maybe Module])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ModNodeKeyWithUid -> IO (UniqDSet UnitId, Maybe Module))
-> [ModNodeKeyWithUid] -> IO [(UniqDSet UnitId, Maybe Module)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ModNodeKeyWithUid -> IO (UniqDSet UnitId, Maybe Module)
get_mod_info [ModNodeKeyWithUid]
all_home_mods
              return (catMaybes mmods, unionManyUniqDSets (init_pkg_set : pkgs))

      let
        -- 2.  Exclude ones already linked
        --      Main reason: avoid findModule calls in get_linkable
            (mods_needed, links_got) = partitionWith split_mods mods_s
            pkgs_needed = UniqDFM UnitId UnitId -> [UnitId]
forall {k} (key :: k) elt. UniqDFM key elt -> [elt]
eltsUDFM (UniqDFM UnitId UnitId -> [UnitId])
-> UniqDFM UnitId UnitId -> [UnitId]
forall a b. (a -> b) -> a -> b
$ UniqDSet UnitId -> UniqDFM UnitId UnitId
forall a. UniqDSet a -> UniqDFM a a
getUniqDSet UniqDSet UnitId
pkgs_s UniqDFM UnitId UnitId
-> UniqDFM UnitId LoadedPkgInfo -> UniqDFM UnitId UnitId
forall {k} (key :: k) elt1 elt2.
UniqDFM key elt1 -> UniqDFM key elt2 -> UniqDFM key elt1
`minusUDFM` LoaderState -> UniqDFM UnitId LoadedPkgInfo
pkgs_loaded LoaderState
pls

            split_mods Module
mod =
                let is_linked :: Maybe Linkable
is_linked = ModuleEnv Linkable -> Module -> Maybe Linkable
forall a. ModuleEnv a -> Module -> Maybe a
lookupModuleEnv (LoaderState -> ModuleEnv Linkable
objs_loaded LoaderState
pls) Module
mod
                                Maybe Linkable -> Maybe Linkable -> Maybe Linkable
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ModuleEnv Linkable -> Module -> Maybe Linkable
forall a. ModuleEnv a -> Module -> Maybe a
lookupModuleEnv (LoaderState -> ModuleEnv Linkable
bcos_loaded LoaderState
pls) Module
mod
                in case Maybe Linkable
is_linked of
                     Just Linkable
linkable -> Linkable -> Either Module Linkable
forall a b. b -> Either a b
Right Linkable
linkable
                     Maybe Linkable
Nothing -> Module -> Either Module Linkable
forall a b. a -> Either a b
Left Module
mod

        -- 3.  For each dependent module, find its linkable
        --     This will either be in the HPT or (in the case of one-shot
        --     compilation) we may need to use maybe_getFileLinkable
      lnks_needed <- mapM (get_linkable (ldObjSuffix opts)) mods_needed

      return $ LinkDeps
        { ldNeededLinkables = lnks_needed
        , ldAllLinkables    = links_got ++ lnks_needed
        , ldUnits           = pkgs_needed
        , ldNeededUnits     = pkgs_s
        }
  where
    mod_graph :: ModuleGraph
mod_graph = LinkDepsOpts -> ModuleGraph
ldModuleGraph LinkDepsOpts
opts
    unit_env :: UnitEnv
unit_env  = LinkDepsOpts -> UnitEnv
ldUnitEnv     LinkDepsOpts
opts

    -- 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 :: (UniqDSet UnitId, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set.Set NodeKey)
    make_deps_loop :: (UniqDSet UnitId, Set NodeKey)
-> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set NodeKey)
make_deps_loop (UniqDSet UnitId, Set NodeKey)
found [] = (UniqDSet UnitId, Set NodeKey)
found
    make_deps_loop found :: (UniqDSet UnitId, Set NodeKey)
found@(UniqDSet UnitId
found_units, Set NodeKey
found_mods) (ModNodeKeyWithUid
nk:[ModNodeKeyWithUid]
nexts)
      | ModNodeKeyWithUid -> NodeKey
NodeKey_Module ModNodeKeyWithUid
nk NodeKey -> Set NodeKey -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set NodeKey
found_mods = (UniqDSet UnitId, Set NodeKey)
-> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set NodeKey)
make_deps_loop (UniqDSet UnitId, Set NodeKey)
found [ModNodeKeyWithUid]
nexts
      | Bool
otherwise =
        case NodeKey -> Map NodeKey (Set NodeKey) -> Maybe (Set NodeKey)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ModNodeKeyWithUid -> NodeKey
NodeKey_Module ModNodeKeyWithUid
nk) (ModuleGraph -> Map NodeKey (Set NodeKey)
mgTransDeps ModuleGraph
mod_graph) of
            Just Set NodeKey
trans_deps ->
              let deps :: Set NodeKey
deps = NodeKey -> Set NodeKey -> Set NodeKey
forall a. Ord a => a -> Set a -> Set a
Set.insert (ModNodeKeyWithUid -> NodeKey
NodeKey_Module ModNodeKeyWithUid
nk) Set NodeKey
trans_deps
                  -- See #936 and the ghci.prog007 test for why we have to continue traversing through
                  -- boot modules.
                  todo_boot_mods :: [ModNodeKeyWithUid]
todo_boot_mods = [ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (ModuleName -> IsBootInterface -> ModuleNameWithIsBoot
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB ModuleName
mn IsBootInterface
NotBoot) UnitId
uid | NodeKey_Module (ModNodeKeyWithUid (GWIB ModuleName
mn IsBootInterface
IsBoot) UnitId
uid) <- Set NodeKey -> [NodeKey]
forall a. Set a -> [a]
Set.toList Set NodeKey
trans_deps]
              in (UniqDSet UnitId, Set NodeKey)
-> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set NodeKey)
make_deps_loop (UniqDSet UnitId
found_units, Set NodeKey
deps Set NodeKey -> Set NodeKey -> Set NodeKey
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set NodeKey
found_mods) ([ModNodeKeyWithUid]
todo_boot_mods [ModNodeKeyWithUid] -> [ModNodeKeyWithUid] -> [ModNodeKeyWithUid]
forall a. [a] -> [a] -> [a]
++ [ModNodeKeyWithUid]
nexts)
            Maybe (Set NodeKey)
Nothing ->
              let (ModNodeKeyWithUid ModuleNameWithIsBoot
_ UnitId
uid) = ModNodeKeyWithUid
nk
              in (UniqDSet UnitId, Set NodeKey)
-> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set NodeKey)
make_deps_loop (UniqDSet UnitId -> UnitId -> UniqDSet UnitId
forall a. Uniquable a => UniqDSet a -> a -> UniqDSet a
addOneToUniqDSet UniqDSet UnitId
found_units UnitId
uid, Set NodeKey
found_mods) [ModNodeKeyWithUid]
nexts

    mkNk :: Module -> ModNodeKeyWithUid
mkNk Module
m = ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (ModuleName -> IsBootInterface -> ModuleNameWithIsBoot
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
m) IsBootInterface
NotBoot) (Module -> UnitId
moduleUnitId Module
m)
    (UniqDSet UnitId
init_pkg_set, Set NodeKey
all_deps) = (UniqDSet UnitId, Set NodeKey)
-> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set NodeKey)
make_deps_loop (UniqDSet UnitId
forall a. UniqDSet a
emptyUniqDSet, Set NodeKey
forall a. Set a
Set.empty) ([ModNodeKeyWithUid] -> (UniqDSet UnitId, Set NodeKey))
-> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set NodeKey)
forall a b. (a -> b) -> a -> b
$ (Module -> ModNodeKeyWithUid) -> [Module] -> [ModNodeKeyWithUid]
forall a b. (a -> b) -> [a] -> [b]
map Module -> ModNodeKeyWithUid
mkNk ((Module -> Bool) -> [Module] -> [Module]
forall a. (a -> Bool) -> [a] -> [a]
filterOut Module -> Bool
isInteractiveModule [Module]
mods)

    all_home_mods :: [ModNodeKeyWithUid]
all_home_mods = [ModNodeKeyWithUid
with_uid | NodeKey_Module ModNodeKeyWithUid
with_uid <- Set NodeKey -> [NodeKey]
forall a. Set a -> [a]
Set.toList Set NodeKey
all_deps]

    get_mod_info :: ModNodeKeyWithUid -> IO (UniqDSet UnitId, Maybe Module)
get_mod_info (ModNodeKeyWithUid ModuleNameWithIsBoot
gwib UnitId
uid) =
      case HomeUnitGraph -> UnitId -> ModuleName -> Maybe HomeModInfo
lookupHug (UnitEnv -> HomeUnitGraph
ue_home_unit_graph UnitEnv
unit_env) UnitId
uid (ModuleNameWithIsBoot -> ModuleName
forall mod. GenWithIsBoot mod -> mod
gwib_mod ModuleNameWithIsBoot
gwib) of
        Just HomeModInfo
hmi ->
          let iface :: ModIface
iface = (HomeModInfo -> ModIface
hm_iface HomeModInfo
hmi)
              mmod :: IO (Maybe Module)
mmod = case ModIface -> HscSource
forall (phase :: ModIfacePhase). ModIface_ phase -> HscSource
mi_hsc_src ModIface
iface of
                      HscSource
HsBootFile -> Module -> IO (Maybe Module)
forall a. Module -> IO a
link_boot_mod_error (ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
iface)
                      HscSource
_          -> Maybe Module -> IO (Maybe Module)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Module -> IO (Maybe Module))
-> Maybe Module -> IO (Maybe Module)
forall a b. (a -> b) -> a -> b
$ Module -> Maybe Module
forall a. a -> Maybe a
Just (ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
iface)

          in ([UnitId] -> UniqDSet UnitId
forall a. Uniquable a => [a] -> UniqDSet a
mkUniqDSet ([UnitId] -> UniqDSet UnitId) -> [UnitId] -> UniqDSet UnitId
forall a b. (a -> b) -> a -> b
$ Set UnitId -> [UnitId]
forall a. Set a -> [a]
Set.toList (Set UnitId -> [UnitId]) -> Set UnitId -> [UnitId]
forall a b. (a -> b) -> a -> b
$ Dependencies -> Set UnitId
dep_direct_pkgs (ModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps ModIface
iface),) (Maybe Module -> (UniqDSet UnitId, Maybe Module))
-> IO (Maybe Module) -> IO (UniqDSet UnitId, Maybe Module)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>  IO (Maybe Module)
mmod
        Maybe HomeModInfo
Nothing -> LinkDepsOpts -> SDoc -> IO (UniqDSet UnitId, Maybe Module)
forall a. LinkDepsOpts -> SDoc -> IO a
throwProgramError LinkDepsOpts
opts (SDoc -> IO (UniqDSet UnitId, Maybe Module))
-> SDoc -> IO (UniqDSet UnitId, Maybe Module)
forall a b. (a -> b) -> a -> b
$
          String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"getLinkDeps: Home module not loaded" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModuleNameWithIsBoot -> ModuleName
forall mod. GenWithIsBoot mod -> mod
gwib_mod ModuleNameWithIsBoot
gwib) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
uid


       -- 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 Module         -- accum. module dependencies
                -> UniqDSet UnitId          -- accum. package dependencies
                -> IO ([Module], UniqDSet UnitId) -- result
    follow_deps :: [Module]
-> UniqDSet Module
-> UniqDSet UnitId
-> IO ([Module], UniqDSet UnitId)
follow_deps []     UniqDSet Module
acc_mods UniqDSet UnitId
acc_pkgs
        = ([Module], UniqDSet UnitId) -> IO ([Module], UniqDSet UnitId)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (UniqDSet Module -> [Module]
forall a. UniqDSet a -> [a]
uniqDSetToList UniqDSet Module
acc_mods, UniqDSet UnitId
acc_pkgs)
    follow_deps (Module
mod:[Module]
mods) UniqDSet Module
acc_mods UniqDSet UnitId
acc_pkgs
        = do
          mb_iface <- LinkDepsOpts
-> SDoc -> Module -> IO (MaybeErr MissingInterfaceError ModIface)
ldLoadIface LinkDepsOpts
opts SDoc
msg Module
mod
          iface <- case mb_iface of
                    Failed MissingInterfaceError
err      -> LinkDepsOpts -> SDoc -> IO ModIface
forall a. LinkDepsOpts -> SDoc -> IO a
throwProgramError LinkDepsOpts
opts (SDoc -> IO ModIface) -> SDoc -> IO ModIface
forall a b. (a -> b) -> a -> b
$
                      IfaceMessageOpts -> MissingInterfaceError -> SDoc
missingInterfaceErrorDiagnostic (LinkDepsOpts -> DiagnosticOpts IfaceMessage
ldMsgOpts LinkDepsOpts
opts) MissingInterfaceError
err
                    Succeeded ModIface
iface -> ModIface -> IO ModIface
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ModIface
iface

          when (mi_boot iface == IsBoot) $ link_boot_mod_error mod

          let
            pkg = Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod
            deps  = ModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps ModIface
iface

            pkg_deps = Dependencies -> Set UnitId
dep_direct_pkgs Dependencies
deps
            (boot_deps, mod_deps) = flip partitionWith (Set.toList (dep_direct_mods deps)) $
              \case
                (UnitId
_, GWIB ModuleName
m IsBootInterface
IsBoot)  -> ModuleName -> Either ModuleName ModuleName
forall a b. a -> Either a b
Left ModuleName
m
                (UnitId
_, GWIB ModuleName
m IsBootInterface
NotBoot) -> ModuleName -> Either ModuleName ModuleName
forall a b. b -> Either a b
Right ModuleName
m

            mod_deps' = case UnitEnv -> Maybe HomeUnit
ue_homeUnit UnitEnv
unit_env of
                          Maybe HomeUnit
Nothing -> []
                          Just HomeUnit
home_unit -> (Module -> Bool) -> [Module] -> [Module]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Module -> Bool) -> Module -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Module -> UniqDSet Module -> Bool
forall a. Uniquable a => a -> UniqDSet a -> Bool
`elementOfUniqDSet` UniqDSet Module
acc_mods)) ((ModuleName -> Module) -> [ModuleName] -> [Module]
forall a b. (a -> b) -> [a] -> [b]
map (HomeUnit -> ModuleName -> Module
mkHomeModule HomeUnit
home_unit) ([ModuleName] -> [Module]) -> [ModuleName] -> [Module]
forall a b. (a -> b) -> a -> b
$ ([ModuleName]
boot_deps [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. [a] -> [a] -> [a]
++ [ModuleName]
mod_deps))
            acc_mods'  = case UnitEnv -> Maybe HomeUnit
ue_homeUnit UnitEnv
unit_env of
                          Maybe HomeUnit
Nothing -> UniqDSet Module
acc_mods
                          Just HomeUnit
home_unit -> UniqDSet Module -> [Module] -> UniqDSet Module
forall a. Uniquable a => UniqDSet a -> [a] -> UniqDSet a
addListToUniqDSet UniqDSet Module
acc_mods (Module
mod Module -> [Module] -> [Module]
forall a. a -> [a] -> [a]
: (ModuleName -> Module) -> [ModuleName] -> [Module]
forall a b. (a -> b) -> [a] -> [b]
map (HomeUnit -> ModuleName -> Module
mkHomeModule HomeUnit
home_unit) [ModuleName]
mod_deps)
            acc_pkgs'  = UniqDSet UnitId -> [UnitId] -> UniqDSet UnitId
forall a. Uniquable a => UniqDSet a -> [a] -> UniqDSet a
addListToUniqDSet UniqDSet UnitId
acc_pkgs (Set UnitId -> [UnitId]
forall a. Set a -> [a]
Set.toList Set UnitId
pkg_deps)

          case ue_homeUnit unit_env of
            Just HomeUnit
home_unit | HomeUnit -> Unit -> Bool
isHomeUnit HomeUnit
home_unit Unit
pkg ->  [Module]
-> UniqDSet Module
-> UniqDSet UnitId
-> IO ([Module], UniqDSet UnitId)
follow_deps ([Module]
mod_deps' [Module] -> [Module] -> [Module]
forall a. [a] -> [a] -> [a]
++ [Module]
mods)
                                                                      UniqDSet Module
acc_mods' UniqDSet UnitId
acc_pkgs'
            Maybe HomeUnit
_ ->  [Module]
-> UniqDSet Module
-> UniqDSet UnitId
-> IO ([Module], UniqDSet UnitId)
follow_deps [Module]
mods UniqDSet Module
acc_mods (UniqDSet UnitId -> UnitId -> UniqDSet UnitId
forall a. Uniquable a => UniqDSet a -> a -> UniqDSet a
addOneToUniqDSet UniqDSet UnitId
acc_pkgs' (Unit -> UnitId
toUnitId Unit
pkg))
        where
           msg :: SDoc
msg = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"need to link module" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                  String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"due to use of Template Haskell"



    link_boot_mod_error :: Module -> IO a
    link_boot_mod_error :: forall a. Module -> IO a
link_boot_mod_error Module
mod = LinkDepsOpts -> SDoc -> IO a
forall a. LinkDepsOpts -> SDoc -> IO a
throwProgramError LinkDepsOpts
opts (SDoc -> IO a) -> SDoc -> IO a
forall a b. (a -> b) -> a -> b
$
            String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"module" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
            String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cannot be linked; it is only available as a boot module"

    no_obj :: Outputable a => a -> IO b
    no_obj :: forall a b. Outputable a => a -> IO b
no_obj a
mod = LinkDepsOpts -> SrcSpan -> SDoc -> IO b
forall a. LinkDepsOpts -> SrcSpan -> SDoc -> IO a
dieWith LinkDepsOpts
opts SrcSpan
span (SDoc -> IO b) -> SDoc -> IO b
forall a b. (a -> b) -> a -> b
$
                     String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cannot find object file for module " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
                        SDoc -> SDoc
quotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
mod) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
                     SDoc
while_linking_expr

    while_linking_expr :: SDoc
while_linking_expr = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"while linking an interpreted expression"


    -- See Note [Using Byte Code rather than Object Code for Template Haskell]
    homeModLinkable :: HomeModInfo -> Maybe Linkable
    homeModLinkable :: HomeModInfo -> Maybe Linkable
homeModLinkable HomeModInfo
hmi =
      if LinkDepsOpts -> Bool
ldUseByteCode LinkDepsOpts
opts
        then HomeModInfo -> Maybe Linkable
homeModInfoByteCode HomeModInfo
hmi Maybe Linkable -> Maybe Linkable -> Maybe Linkable
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> HomeModInfo -> Maybe Linkable
homeModInfoObject HomeModInfo
hmi
        else HomeModInfo -> Maybe Linkable
homeModInfoObject HomeModInfo
hmi   Maybe Linkable -> Maybe Linkable -> Maybe Linkable
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> HomeModInfo -> Maybe Linkable
homeModInfoByteCode HomeModInfo
hmi

    get_linkable :: String -> Module -> IO Linkable
get_linkable String
osuf Module
mod      -- A home-package module
        | Just HomeModInfo
mod_info <- Module -> HomeUnitGraph -> Maybe HomeModInfo
lookupHugByModule Module
mod (UnitEnv -> HomeUnitGraph
ue_home_unit_graph UnitEnv
unit_env)
        = Linkable -> IO Linkable
adjust_linkable (String -> Maybe Linkable -> Linkable
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"getLinkDeps" (HomeModInfo -> Maybe Linkable
homeModLinkable HomeModInfo
mod_info))
        | Bool
otherwise
        = do    -- It's not in the HPT because we are in one shot mode,
                -- so use the Finder to get a ModLocation...
             case UnitEnv -> Maybe HomeUnit
ue_homeUnit UnitEnv
unit_env of
              Maybe HomeUnit
Nothing -> Module -> IO Linkable
forall a b. Outputable a => a -> IO b
no_obj Module
mod
              Just HomeUnit
home_unit -> do

                let fc :: FinderCache
fc = LinkDepsOpts -> FinderCache
ldFinderCache LinkDepsOpts
opts
                let fopts :: FinderOpts
fopts = LinkDepsOpts -> FinderOpts
ldFinderOpts LinkDepsOpts
opts
                mb_stuff <- FinderCache
-> FinderOpts -> HomeUnit -> ModuleName -> IO FindResult
findHomeModule FinderCache
fc FinderOpts
fopts HomeUnit
home_unit (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod)
                case mb_stuff of
                  Found ModLocation
loc Module
mod -> ModLocation -> Module -> IO Linkable
found ModLocation
loc Module
mod
                  FindResult
_ -> ModuleName -> IO Linkable
forall a b. Outputable a => a -> IO b
no_obj (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod)
        where
            found :: ModLocation -> Module -> IO Linkable
found ModLocation
loc Module
mod = do {
                -- ...and then find the linkable for it
               mb_lnk <- Module -> ModLocation -> IO (Maybe Linkable)
findObjectLinkableMaybe Module
mod ModLocation
loc ;
               case mb_lnk of {
                  Maybe Linkable
Nothing  -> Module -> IO Linkable
forall a b. Outputable a => a -> IO b
no_obj Module
mod ;
                  Just Linkable
lnk -> Linkable -> IO Linkable
adjust_linkable Linkable
lnk
              }}

            adjust_linkable :: Linkable -> IO Linkable
adjust_linkable Linkable
lnk
                | Just String
new_osuf <- Maybe String
maybe_normal_osuf = do
                        new_uls <- (Unlinked -> IO Unlinked) -> [Unlinked] -> IO [Unlinked]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> Unlinked -> IO Unlinked
adjust_ul String
new_osuf)
                                        (Linkable -> [Unlinked]
linkableUnlinked Linkable
lnk)
                        return lnk{ linkableUnlinked=new_uls }
                | Bool
otherwise =
                        Linkable -> IO Linkable
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Linkable
lnk

            adjust_ul :: String -> Unlinked -> IO Unlinked
adjust_ul String
new_osuf (DotO String
file) = do
                Bool -> IO ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (String
osuf String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
file)
                let file_base :: String
file_base = Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (String -> String -> Maybe String
stripExtension String
osuf String
file)
                    new_file :: String
new_file = String
file_base String -> String -> String
<.> String
new_osuf
                ok <- String -> IO Bool
doesFileExist String
new_file
                if (not ok)
                   then dieWith opts span $
                          text "cannot find object file "
                                <> quotes (text new_file) $$ while_linking_expr
                   else return (DotO new_file)
            adjust_ul String
_ (DotA String
fp) = String -> IO Unlinked
forall a. HasCallStack => String -> a
panic (String
"adjust_ul DotA " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
fp)
            adjust_ul String
_ (DotDLL String
fp) = String -> IO Unlinked
forall a. HasCallStack => String -> a
panic (String
"adjust_ul DotDLL " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
fp)
            adjust_ul String
_ l :: Unlinked
l@(BCOs {}) = Unlinked -> IO Unlinked
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Unlinked
l
            adjust_ul String
_ l :: Unlinked
l@LoadedBCOs{} = Unlinked -> IO Unlinked
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Unlinked
l
            adjust_ul String
_ (CoreBindings (WholeCoreBindings [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
_ Module
mod ModLocation
_))     = String -> SDoc -> IO Unlinked
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Unhydrated core bindings" (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod)

{-
Note [Using Byte Code rather than Object Code for Template Haskell]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The `-fprefer-byte-code` flag allows a user to specify that they want to use
byte code (if available) rather than object code for home module dependencies
when executing Template Haskell splices.

Why might you want to use byte code rather than object code?

* Producing object code is much slower than producing byte code (for example if you're using -fno-code)
* Linking many large object files, which happens once per splice, is quite expensive. (#21700)

So we allow the user to choose to use byte code rather than object files if they want to avoid these
two pitfalls.

When using `-fprefer-byte-code` you have to arrange to have the byte code available.
In normal --make mode it will not be produced unless you enable `-fbyte-code-and-object-code`.
See Note [Home module build products] for some more information about that.

The only other place where the flag is consulted is when enabling code generation
with `-fno-code`, which does so to anticipate what decision we will make at the
splice point about what we would prefer.

-}

dieWith :: LinkDepsOpts -> SrcSpan -> SDoc -> IO a
dieWith :: forall a. LinkDepsOpts -> SrcSpan -> SDoc -> IO a
dieWith LinkDepsOpts
opts SrcSpan
span SDoc
msg = LinkDepsOpts -> SDoc -> IO a
forall a. LinkDepsOpts -> SDoc -> IO a
throwProgramError LinkDepsOpts
opts (MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessage MessageClass
MCFatal SrcSpan
span SDoc
msg)

throwProgramError :: LinkDepsOpts -> SDoc -> IO a
throwProgramError :: forall a. LinkDepsOpts -> SDoc -> IO a
throwProgramError LinkDepsOpts
opts SDoc
doc = GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO (String -> GhcException
ProgramError (SDocContext -> SDoc -> String
renderWithContext (LinkDepsOpts -> SDocContext
ldPprOpts LinkDepsOpts
opts) SDoc
doc))

checkNonStdWay :: LinkDepsOpts -> Interp -> SrcSpan -> IO (Maybe FilePath)
checkNonStdWay :: LinkDepsOpts -> Interp -> SrcSpan -> IO (Maybe String)
checkNonStdWay LinkDepsOpts
_opts Interp
interp SrcSpan
_srcspan
  | ExternalInterp {} <- Interp -> InterpInstance
interpInstance Interp
interp = Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
    -- with -fexternal-interpreter we load the .o files, whatever way
    -- they were built.  If they were built for a non-std way, then
    -- we will use the appropriate variant of the iserv binary to load them.

-- #if-guard the following equations otherwise the pattern match checker will
-- complain that they are redundant.
#if defined(HAVE_INTERNAL_INTERPRETER)
checkNonStdWay LinkDepsOpts
opts Interp
_interp SrcSpan
srcspan
  | Ways
hostFullWays Ways -> Ways -> Bool
forall a. Eq a => a -> a -> Bool
== Ways
targetFullWays = Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
    -- Only if we are compiling with the same ways as GHC is built
    -- with, can we dynamically load those object files. (see #3604)

  | LinkDepsOpts -> String
ldObjSuffix LinkDepsOpts
opts String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
normalObjectSuffix Bool -> Bool -> Bool
&& Bool -> Bool
not (Ways -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Ways
targetFullWays)
  = LinkDepsOpts -> SrcSpan -> IO (Maybe String)
failNonStd LinkDepsOpts
opts SrcSpan
srcspan

  | Bool
otherwise = Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just (String
hostWayTag String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"o"))
  where
    targetFullWays :: Ways
targetFullWays = Ways -> Ways
fullWays (LinkDepsOpts -> Ways
ldWays LinkDepsOpts
opts)
    hostWayTag :: String
hostWayTag = case Ways -> String
waysTag Ways
hostFullWays of
                  String
"" -> String
""
                  String
tag -> String
tag String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_"

    normalObjectSuffix :: String
    normalObjectSuffix :: String
normalObjectSuffix = String
"o"

data Way' = Normal | Prof | Dyn

failNonStd :: LinkDepsOpts -> SrcSpan -> IO (Maybe FilePath)
failNonStd :: LinkDepsOpts -> SrcSpan -> IO (Maybe String)
failNonStd LinkDepsOpts
opts SrcSpan
srcspan = LinkDepsOpts -> SrcSpan -> SDoc -> IO (Maybe String)
forall a. LinkDepsOpts -> SrcSpan -> SDoc -> IO a
dieWith LinkDepsOpts
opts SrcSpan
srcspan (SDoc -> IO (Maybe String)) -> SDoc -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$
  String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Cannot load" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Way' -> SDoc
pprWay' Way'
compWay SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
     String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"objects when GHC is built" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Way' -> SDoc
pprWay' Way'
ghciWay SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
  String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"To fix this, either:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
  String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"  (1) Use -fexternal-interpreter, or" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
  SDoc
buildTwiceMsg
    where compWay :: Way'
compWay
            | LinkDepsOpts -> Ways
ldWays LinkDepsOpts
opts Ways -> Way -> Bool
`hasWay` Way
WayDyn  = Way'
Dyn
            | LinkDepsOpts -> Ways
ldWays LinkDepsOpts
opts Ways -> Way -> Bool
`hasWay` Way
WayProf = Way'
Prof
            | Bool
otherwise = Way'
Normal
          ghciWay :: Way'
ghciWay
            | Bool
hostIsDynamic = Way'
Dyn
            | Bool
hostIsProfiled = Way'
Prof
            | Bool
otherwise = Way'
Normal
          buildTwiceMsg :: SDoc
buildTwiceMsg = case (Way'
ghciWay, Way'
compWay) of
            (Way'
Normal, Way'
Dyn) -> SDoc
dynamicTooMsg
            (Way'
Dyn, Way'
Normal) -> SDoc
dynamicTooMsg
            (Way', Way')
_ ->
              String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"  (2) Build the program twice: once" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                Way' -> SDoc
pprWay' Way'
ghciWay SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
", and then" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
              String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"      " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Way' -> SDoc
pprWay' Way'
compWay SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"using -osuf to set a different object file suffix."
          dynamicTooMsg :: SDoc
dynamicTooMsg = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"  (2) Use -dynamic-too," SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
            String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"and use -osuf and -dynosuf to set object file suffixes as needed."
          pprWay' :: Way' -> SDoc
          pprWay' :: Way' -> SDoc
pprWay' Way'
way = String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ case Way'
way of
            Way'
Normal -> String
"the normal way"
            Way'
Prof -> String
"with -prof"
            Way'
Dyn -> String
"with -dynamic"
#endif