never executed always true always false
    1 {-# LANGUAGE CPP #-}
    2 {-# LANGUAGE TupleSections, RecordWildCards #-}
    3 {-# LANGUAGE BangPatterns #-}
    4 {-# LANGUAGE LambdaCase #-}
    5 
    6 --
    7 --  (c) The University of Glasgow 2002-2006
    8 
    9 -- | The loader
   10 --
   11 -- This module deals with the top-level issues of dynamic linking (loading),
   12 -- calling the object-code linker and the byte-code linker where necessary.
   13 module GHC.Linker.Loader
   14    ( Loader (..)
   15    , LoaderState (..)
   16    , initLoaderState
   17    , uninitializedLoader
   18    , showLoaderState
   19    , getLoaderState
   20    -- * Load & Unload
   21    , loadExpr
   22    , loadDecls
   23    , loadPackages
   24    , loadModule
   25    , loadCmdLineLibs
   26    , loadName
   27    , unload
   28    -- * LoadedEnv
   29    , withExtendedLoadedEnv
   30    , extendLoadedEnv
   31    , deleteFromLoadedEnv
   32    -- * Misc
   33    , extendLoadedPkgs
   34    )
   35 where
   36 
   37 import GHC.Prelude
   38 
   39 import GHC.Settings
   40 
   41 import GHC.Platform
   42 import GHC.Platform.Ways
   43 
   44 import GHC.Driver.Phases
   45 import GHC.Driver.Env
   46 import GHC.Driver.Session
   47 import GHC.Driver.Ppr
   48 import GHC.Driver.Config
   49 import GHC.Driver.Config.Diagnostic
   50 import GHC.Driver.Config.Finder
   51 
   52 import GHC.Tc.Utils.Monad
   53 
   54 import GHC.Runtime.Interpreter
   55 import GHCi.RemoteTypes
   56 
   57 import GHC.Iface.Load
   58 
   59 import GHC.ByteCode.Linker
   60 import GHC.ByteCode.Asm
   61 import GHC.ByteCode.Types
   62 
   63 import GHC.SysTools
   64 
   65 import GHC.Types.Basic
   66 import GHC.Types.Name
   67 import GHC.Types.Name.Env
   68 import GHC.Types.SrcLoc
   69 import GHC.Types.Unique.DSet
   70 
   71 import GHC.Utils.Outputable
   72 import GHC.Utils.Panic
   73 import GHC.Utils.Panic.Plain
   74 import GHC.Utils.Constants (isWindowsHost, isDarwinHost)
   75 import GHC.Utils.Misc
   76 import GHC.Utils.Error
   77 import GHC.Utils.Logger
   78 import GHC.Utils.TmpFs
   79 
   80 import GHC.Unit.Env
   81 import GHC.Unit.Finder
   82 import GHC.Unit.Module
   83 import GHC.Unit.Module.ModIface
   84 import GHC.Unit.Module.Deps
   85 import GHC.Unit.Home
   86 import GHC.Unit.Home.ModInfo
   87 import GHC.Unit.State as Packages
   88 
   89 import qualified GHC.Data.ShortText as ST
   90 import qualified GHC.Data.Maybe as Maybes
   91 import GHC.Data.FastString
   92 import GHC.Data.List.SetOps
   93 
   94 import GHC.Linker.MacOS
   95 import GHC.Linker.Dynamic
   96 import GHC.Linker.Types
   97 
   98 -- Standard libraries
   99 import Control.Monad
  100 
  101 import qualified Data.Set as Set
  102 import Data.Char (isSpace)
  103 import Data.IORef
  104 import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition, find)
  105 import Data.Maybe
  106 import Control.Concurrent.MVar
  107 import qualified Control.Monad.Catch as MC
  108 
  109 import System.FilePath
  110 import System.Directory
  111 import System.IO.Unsafe
  112 import System.Environment (lookupEnv)
  113 
  114 #if defined(mingw32_HOST_OS)
  115 import System.Win32.Info (getSystemDirectory)
  116 #endif
  117 
  118 import GHC.Utils.Exception
  119 import qualified Data.Map as M
  120 import Data.Either (partitionEithers)
  121 
  122 uninitialised :: a
  123 uninitialised = panic "Loader not initialised"
  124 
  125 modifyLoaderState_ :: Interp -> (LoaderState -> IO LoaderState) -> IO ()
  126 modifyLoaderState_ interp f =
  127   modifyMVar_ (loader_state (interpLoader interp))
  128     (fmap pure . f . fromMaybe uninitialised)
  129 
  130 modifyLoaderState :: Interp -> (LoaderState -> IO (LoaderState, a)) -> IO a
  131 modifyLoaderState interp f =
  132   modifyMVar (loader_state (interpLoader interp))
  133     (fmapFst pure . f . fromMaybe uninitialised)
  134   where fmapFst f = fmap (\(x, y) -> (f x, y))
  135 
  136 getLoaderState :: Interp -> IO (Maybe LoaderState)
  137 getLoaderState interp = readMVar (loader_state (interpLoader interp))
  138 
  139 
  140 emptyLoaderState :: LoaderState
  141 emptyLoaderState = LoaderState
  142    { closure_env = emptyNameEnv
  143    , itbl_env    = emptyNameEnv
  144    , pkgs_loaded = init_pkgs
  145    , bcos_loaded = []
  146    , objs_loaded = []
  147    , hs_objs_loaded = []
  148    , non_hs_objs_loaded = []
  149    , module_deps = M.empty
  150    , temp_sos = []
  151    }
  152   -- Packages that don't need loading, because the compiler
  153   -- shares them with the interpreted program.
  154   --
  155   -- The linker's symbol table is populated with RTS symbols using an
  156   -- explicit list.  See rts/Linker.c for details.
  157   where init_pkgs = [rtsUnitId]
  158 
  159 extendLoadedPkgs :: Interp -> [UnitId] -> IO ()
  160 extendLoadedPkgs interp pkgs =
  161   modifyLoaderState_ interp $ \s ->
  162       return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }
  163 
  164 extendLoadedEnv :: Interp -> [(Name,ForeignHValue)] -> IO ()
  165 extendLoadedEnv interp new_bindings =
  166   modifyLoaderState_ interp $ \pls@LoaderState{..} -> do
  167     let new_ce = extendClosureEnv closure_env new_bindings
  168     return $! pls{ closure_env = new_ce }
  169     -- strictness is important for not retaining old copies of the pls
  170 
  171 deleteFromLoadedEnv :: Interp -> [Name] -> IO ()
  172 deleteFromLoadedEnv interp to_remove =
  173   modifyLoaderState_ interp $ \pls -> do
  174     let ce = closure_env pls
  175     let new_ce = delListFromNameEnv ce to_remove
  176     return pls{ closure_env = new_ce }
  177 
  178 -- | Load the module containing the given Name and get its associated 'HValue'.
  179 --
  180 -- Throws a 'ProgramError' if loading fails or the name cannot be found.
  181 loadName :: Interp -> HscEnv -> Maybe ModuleNameWithIsBoot -> Name -> IO ForeignHValue
  182 loadName interp hsc_env mnwib name = do
  183   initLoaderState interp hsc_env
  184   modifyLoaderState interp $ \pls0 -> do
  185     pls <- if not (isExternalName name)
  186        then return pls0
  187        else do
  188          (pls', ok) <- loadDependencies interp hsc_env pls0 (noSrcSpan, mnwib)
  189                           [nameModule name]
  190          if failed ok
  191            then throwGhcExceptionIO (ProgramError "")
  192            else return pls'
  193 
  194     case lookupNameEnv (closure_env pls) name of
  195       Just (_,aa) -> return (pls,aa)
  196       Nothing     -> assertPpr (isExternalName name) (ppr name) $
  197                      do let sym_to_find = nameToCLabel name "closure"
  198                         m <- lookupClosure interp (unpackFS sym_to_find)
  199                         r <- case m of
  200                           Just hvref -> mkFinalizedHValue interp hvref
  201                           Nothing -> linkFail "GHC.Linker.Loader.loadName"
  202                                        (unpackFS sym_to_find)
  203                         return (pls,r)
  204 
  205 loadDependencies
  206   :: Interp
  207   -> HscEnv
  208   -> LoaderState
  209   -> (SrcSpan, Maybe ModuleNameWithIsBoot) -> [Module]
  210   -> IO (LoaderState, SuccessFlag)
  211 loadDependencies interp hsc_env pls span needed_mods = do
  212 --   initLoaderState (hsc_dflags hsc_env) dl
  213    let hpt = hsc_HPT hsc_env
  214    let dflags = hsc_dflags hsc_env
  215    -- The interpreter and dynamic linker can only handle object code built
  216    -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
  217    -- So here we check the build tag: if we're building a non-standard way
  218    -- then we need to find & link object files built the "normal" way.
  219    maybe_normal_osuf <- checkNonStdWay dflags interp (fst span)
  220 
  221    -- Find what packages and linkables are required
  222    (lnks, all_lnks, pkgs) <- getLinkDeps hsc_env hpt pls
  223                                maybe_normal_osuf (fst span) needed_mods
  224 
  225    let pls1 =
  226         case (snd span) of
  227           Just mn -> pls { module_deps = M.insertWith (++) mn all_lnks (module_deps pls) }
  228           Nothing -> pls
  229 
  230    -- Link the packages and modules required
  231    pls2 <- loadPackages' interp hsc_env pkgs pls1
  232    loadModules interp hsc_env pls2 lnks
  233 
  234 
  235 -- | Temporarily extend the loaded env.
  236 withExtendedLoadedEnv
  237   :: (ExceptionMonad m)
  238   => Interp
  239   -> [(Name,ForeignHValue)]
  240   -> m a
  241   -> m a
  242 withExtendedLoadedEnv interp new_env action
  243     = MC.bracket (liftIO $ extendLoadedEnv interp new_env)
  244                (\_ -> reset_old_env)
  245                (\_ -> action)
  246     where
  247         -- Remember that the linker state might be side-effected
  248         -- during the execution of the IO action, and we don't want to
  249         -- lose those changes (we might have linked a new module or
  250         -- package), so the reset action only removes the names we
  251         -- added earlier.
  252           reset_old_env = liftIO $
  253             modifyLoaderState_ interp $ \pls ->
  254                 let cur = closure_env pls
  255                     new = delListFromNameEnv cur (map fst new_env)
  256                 in return pls{ closure_env = new }
  257 
  258 
  259 -- | Display the loader state.
  260 showLoaderState :: Interp -> IO SDoc
  261 showLoaderState interp = do
  262   ls <- readMVar (loader_state (interpLoader interp))
  263   let docs = case ls of
  264         Nothing  -> [ text "Loader not initialised"]
  265         Just pls -> [ text "Pkgs:" <+> ppr (pkgs_loaded pls)
  266                     , text "Objs:" <+> ppr (objs_loaded pls)
  267                     , text "BCOs:" <+> ppr (bcos_loaded pls)
  268                     ]
  269 
  270   return $ withPprStyle defaultDumpStyle
  271          $ vcat (text "----- Loader state -----":docs)
  272 
  273 
  274 {- **********************************************************************
  275 
  276                         Initialisation
  277 
  278   ********************************************************************* -}
  279 
  280 -- | Initialise the dynamic linker.  This entails
  281 --
  282 --  a) Calling the C initialisation procedure,
  283 --
  284 --  b) Loading any packages specified on the command line,
  285 --
  286 --  c) Loading any packages specified on the command line, now held in the
  287 --     @-l@ options in @v_Opt_l@,
  288 --
  289 --  d) Loading any @.o\/.dll@ files specified on the command line, now held
  290 --     in @ldInputs@,
  291 --
  292 --  e) Loading any MacOS frameworks.
  293 --
  294 -- NOTE: This function is idempotent; if called more than once, it does
  295 -- nothing.  This is useful in Template Haskell, where we call it before
  296 -- trying to link.
  297 --
  298 initLoaderState :: Interp -> HscEnv -> IO ()
  299 initLoaderState interp hsc_env = do
  300   modifyMVar_ (loader_state (interpLoader interp)) $ \pls -> do
  301     case pls of
  302       Just  _ -> return pls
  303       Nothing -> Just <$> reallyInitLoaderState interp hsc_env
  304 
  305 reallyInitLoaderState :: Interp -> HscEnv -> IO LoaderState
  306 reallyInitLoaderState interp hsc_env = do
  307   -- Initialise the linker state
  308   let pls0 = emptyLoaderState
  309 
  310   -- (a) initialise the C dynamic linker
  311   initObjLinker interp
  312 
  313   -- (b) Load packages from the command-line (Note [preload packages])
  314   pls <- loadPackages' interp hsc_env (preloadUnits (hsc_units hsc_env)) pls0
  315 
  316   -- steps (c), (d) and (e)
  317   loadCmdLineLibs' interp hsc_env pls
  318 
  319 
  320 loadCmdLineLibs :: Interp -> HscEnv -> IO ()
  321 loadCmdLineLibs interp hsc_env = do
  322   initLoaderState interp hsc_env
  323   modifyLoaderState_ interp $ \pls ->
  324     loadCmdLineLibs' interp hsc_env pls
  325 
  326 loadCmdLineLibs'
  327   :: Interp
  328   -> HscEnv
  329   -> LoaderState
  330   -> IO LoaderState
  331 loadCmdLineLibs' interp hsc_env pls =
  332   do
  333       let dflags@(DynFlags { ldInputs = cmdline_ld_inputs
  334                            , libraryPaths = lib_paths_base})
  335             = hsc_dflags hsc_env
  336       let logger = hsc_logger hsc_env
  337 
  338       -- (c) Link libraries from the command-line
  339       let minus_ls_1 = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ]
  340 
  341       -- On Windows we want to add libpthread by default just as GCC would.
  342       -- However because we don't know the actual name of pthread's dll we
  343       -- need to defer this to the locateLib call so we can't initialize it
  344       -- inside of the rts. Instead we do it here to be able to find the
  345       -- import library for pthreads. See #13210.
  346       let platform = targetPlatform dflags
  347           os       = platformOS platform
  348           minus_ls = case os of
  349                        OSMinGW32 -> "pthread" : minus_ls_1
  350                        _         -> minus_ls_1
  351       -- See Note [Fork/Exec Windows]
  352       gcc_paths <- getGCCPaths logger dflags os
  353 
  354       lib_paths_env <- addEnvPaths "LIBRARY_PATH" lib_paths_base
  355 
  356       maybePutStrLn logger "Search directories (user):"
  357       maybePutStr logger (unlines $ map ("  "++) lib_paths_env)
  358       maybePutStrLn logger "Search directories (gcc):"
  359       maybePutStr logger (unlines $ map ("  "++) gcc_paths)
  360 
  361       libspecs
  362         <- mapM (locateLib interp hsc_env False lib_paths_env gcc_paths) minus_ls
  363 
  364       -- (d) Link .o files from the command-line
  365       classified_ld_inputs <- mapM (classifyLdInput logger platform)
  366                                 [ f | FileOption _ f <- cmdline_ld_inputs ]
  367 
  368       -- (e) Link any MacOS frameworks
  369       let platform = targetPlatform dflags
  370       let (framework_paths, frameworks) =
  371             if platformUsesFrameworks platform
  372              then (frameworkPaths dflags, cmdlineFrameworks dflags)
  373               else ([],[])
  374 
  375       -- Finally do (c),(d),(e)
  376       let cmdline_lib_specs = catMaybes classified_ld_inputs
  377                            ++ libspecs
  378                            ++ map Framework frameworks
  379       if null cmdline_lib_specs
  380          then return pls
  381          else do
  382            -- Add directories to library search paths, this only has an effect
  383            -- on Windows. On Unix OSes this function is a NOP.
  384            let all_paths = let paths = takeDirectory (pgm_c dflags)
  385                                      : framework_paths
  386                                     ++ lib_paths_base
  387                                     ++ [ takeDirectory dll | DLLPath dll <- libspecs ]
  388                            in nub $ map normalise paths
  389            let lib_paths = nub $ lib_paths_base ++ gcc_paths
  390            all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths
  391            pathCache <- mapM (addLibrarySearchPath interp) all_paths_env
  392 
  393            let merged_specs = mergeStaticObjects cmdline_lib_specs
  394            pls1 <- foldM (preloadLib interp hsc_env lib_paths framework_paths) pls
  395                          merged_specs
  396 
  397            maybePutStr logger "final link ... "
  398            ok <- resolveObjs interp
  399 
  400            -- DLLs are loaded, reset the search paths
  401            mapM_ (removeLibrarySearchPath interp) $ reverse pathCache
  402 
  403            if succeeded ok then maybePutStrLn logger "done"
  404            else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed")
  405 
  406            return pls1
  407 
  408 -- | Merge runs of consecutive of 'Objects'. This allows for resolution of
  409 -- cyclic symbol references when dynamically linking. Specifically, we link
  410 -- together all of the static objects into a single shared object, avoiding
  411 -- the issue we saw in #13786.
  412 mergeStaticObjects :: [LibrarySpec] -> [LibrarySpec]
  413 mergeStaticObjects specs = go [] specs
  414   where
  415     go :: [FilePath] -> [LibrarySpec] -> [LibrarySpec]
  416     go accum (Objects objs : rest) = go (objs ++ accum) rest
  417     go accum@(_:_) rest = Objects (reverse accum) : go [] rest
  418     go [] (spec:rest) = spec : go [] rest
  419     go [] [] = []
  420 
  421 {- Note [preload packages]
  422 
  423 Why do we need to preload packages from the command line?  This is an
  424 explanation copied from #2437:
  425 
  426 I tried to implement the suggestion from #3560, thinking it would be
  427 easy, but there are two reasons we link in packages eagerly when they
  428 are mentioned on the command line:
  429 
  430   * So that you can link in extra object files or libraries that
  431     depend on the packages. e.g. ghc -package foo -lbar where bar is a
  432     C library that depends on something in foo. So we could link in
  433     foo eagerly if and only if there are extra C libs or objects to
  434     link in, but....
  435 
  436   * Haskell code can depend on a C function exported by a package, and
  437     the normal dependency tracking that TH uses can't know about these
  438     dependencies. The test ghcilink004 relies on this, for example.
  439 
  440 I conclude that we need two -package flags: one that says "this is a
  441 package I want to make available", and one that says "this is a
  442 package I want to link in eagerly". Would that be too complicated for
  443 users?
  444 -}
  445 
  446 classifyLdInput :: Logger -> Platform -> FilePath -> IO (Maybe LibrarySpec)
  447 classifyLdInput logger platform f
  448   | isObjectFilename platform f = return (Just (Objects [f]))
  449   | isDynLibFilename platform f = return (Just (DLLPath f))
  450   | otherwise          = do
  451         logMsg logger MCInfo noSrcSpan
  452             $ withPprStyle defaultUserStyle
  453             (text ("Warning: ignoring unrecognised input `" ++ f ++ "'"))
  454         return Nothing
  455 
  456 preloadLib
  457   :: Interp
  458   -> HscEnv
  459   -> [String]
  460   -> [String]
  461   -> LoaderState
  462   -> LibrarySpec
  463   -> IO LoaderState
  464 preloadLib interp hsc_env lib_paths framework_paths pls lib_spec = do
  465   maybePutStr logger ("Loading object " ++ showLS lib_spec ++ " ... ")
  466   case lib_spec of
  467     Objects static_ishs -> do
  468       (b, pls1) <- preload_statics lib_paths static_ishs
  469       maybePutStrLn logger (if b  then "done" else "not found")
  470       return pls1
  471 
  472     Archive static_ish -> do
  473       b <- preload_static_archive lib_paths static_ish
  474       maybePutStrLn logger (if b  then "done" else "not found")
  475       return pls
  476 
  477     DLL dll_unadorned -> do
  478       maybe_errstr <- loadDLL interp (platformSOName platform dll_unadorned)
  479       case maybe_errstr of
  480          Nothing -> maybePutStrLn logger "done"
  481          Just mm | platformOS platform /= OSDarwin ->
  482            preloadFailed mm lib_paths lib_spec
  483          Just mm | otherwise -> do
  484            -- As a backup, on Darwin, try to also load a .so file
  485            -- since (apparently) some things install that way - see
  486            -- ticket #8770.
  487            let libfile = ("lib" ++ dll_unadorned) <.> "so"
  488            err2 <- loadDLL interp libfile
  489            case err2 of
  490              Nothing -> maybePutStrLn logger "done"
  491              Just _  -> preloadFailed mm lib_paths lib_spec
  492       return pls
  493 
  494     DLLPath dll_path -> do
  495       do maybe_errstr <- loadDLL interp dll_path
  496          case maybe_errstr of
  497             Nothing -> maybePutStrLn logger "done"
  498             Just mm -> preloadFailed mm lib_paths lib_spec
  499          return pls
  500 
  501     Framework framework ->
  502       if platformUsesFrameworks (targetPlatform dflags)
  503       then do maybe_errstr <- loadFramework interp framework_paths framework
  504               case maybe_errstr of
  505                  Nothing -> maybePutStrLn logger "done"
  506                  Just mm -> preloadFailed mm framework_paths lib_spec
  507               return pls
  508       else throwGhcExceptionIO (ProgramError "preloadLib Framework")
  509 
  510   where
  511     dflags = hsc_dflags hsc_env
  512     logger = hsc_logger hsc_env
  513 
  514     platform = targetPlatform dflags
  515 
  516     preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
  517     preloadFailed sys_errmsg paths spec
  518        = do maybePutStr logger "failed.\n"
  519             throwGhcExceptionIO $
  520               CmdLineError (
  521                     "user specified .o/.so/.DLL could not be loaded ("
  522                     ++ sys_errmsg ++ ")\nWhilst trying to load:  "
  523                     ++ showLS spec ++ "\nAdditional directories searched:"
  524                     ++ (if null paths then " (none)" else
  525                         intercalate "\n" (map ("   "++) paths)))
  526 
  527     -- Not interested in the paths in the static case.
  528     preload_statics _paths names
  529        = do b <- or <$> mapM doesFileExist names
  530             if not b then return (False, pls)
  531                      else if hostIsDynamic
  532                              then  do pls1 <- dynLoadObjs interp hsc_env pls names
  533                                       return (True, pls1)
  534                              else  do mapM_ (loadObj interp) names
  535                                       return (True, pls)
  536 
  537     preload_static_archive _paths name
  538        = do b <- doesFileExist name
  539             if not b then return False
  540                      else do if hostIsDynamic
  541                                  then throwGhcExceptionIO $
  542                                       CmdLineError dynamic_msg
  543                                  else loadArchive interp name
  544                              return True
  545       where
  546         dynamic_msg = unlines
  547           [ "User-specified static library could not be loaded ("
  548             ++ name ++ ")"
  549           , "Loading static libraries is not supported in this configuration."
  550           , "Try using a dynamic library instead."
  551           ]
  552 
  553 
  554 {- **********************************************************************
  555 
  556                         Link a byte-code expression
  557 
  558   ********************************************************************* -}
  559 
  560 -- | Load a single expression, /including/ first loading packages and
  561 -- modules that this expression depends on.
  562 --
  563 -- Raises an IO exception ('ProgramError') if it can't find a compiled
  564 -- version of the dependents to load.
  565 --
  566 loadExpr :: Interp -> HscEnv -> (SrcSpan, Maybe ModuleNameWithIsBoot) -> UnlinkedBCO -> IO ForeignHValue
  567 loadExpr interp hsc_env span root_ul_bco = do
  568   -- Initialise the linker (if it's not been done already)
  569   initLoaderState interp hsc_env
  570 
  571   -- Take lock for the actual work.
  572   modifyLoaderState interp $ \pls0 -> do
  573     -- Load the packages and modules required
  574     (pls, ok) <- loadDependencies interp hsc_env pls0 span needed_mods
  575     if failed ok
  576       then throwGhcExceptionIO (ProgramError "")
  577       else do
  578         -- Load the expression itself
  579         let ie = itbl_env pls
  580             ce = closure_env pls
  581 
  582         -- Load the necessary packages and linkables
  583         let nobreakarray = error "no break array"
  584             bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)]
  585         resolved <- linkBCO interp ie ce bco_ix nobreakarray root_ul_bco
  586         bco_opts <- initBCOOpts (hsc_dflags hsc_env)
  587         [root_hvref] <- createBCOs interp bco_opts [resolved]
  588         fhv <- mkFinalizedHValue interp root_hvref
  589         return (pls, fhv)
  590   where
  591      free_names = uniqDSetToList (bcoFreeNames root_ul_bco)
  592 
  593      needed_mods :: [Module]
  594      needed_mods = [ nameModule n | n <- free_names,
  595                      isExternalName n,      -- Names from other modules
  596                      not (isWiredInName n)  -- Exclude wired-in names
  597                    ]                        -- (see note below)
  598         -- Exclude wired-in names because we may not have read
  599         -- their interface files, so getLinkDeps will fail
  600         -- All wired-in names are in the base package, which we link
  601         -- by default, so we can safely ignore them here.
  602 
  603 dieWith :: DynFlags -> SrcSpan -> SDoc -> IO a
  604 dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage MCFatal span msg)))
  605 
  606 
  607 checkNonStdWay :: DynFlags -> Interp -> SrcSpan -> IO (Maybe FilePath)
  608 checkNonStdWay dflags interp srcspan
  609   | ExternalInterp {} <- interpInstance interp = return Nothing
  610     -- with -fexternal-interpreter we load the .o files, whatever way
  611     -- they were built.  If they were built for a non-std way, then
  612     -- we will use the appropriate variant of the iserv binary to load them.
  613 
  614   | hostFullWays == targetFullWays = return Nothing
  615     -- Only if we are compiling with the same ways as GHC is built
  616     -- with, can we dynamically load those object files. (see #3604)
  617 
  618   | objectSuf_ dflags == normalObjectSuffix && not (null targetFullWays)
  619   = failNonStd dflags srcspan
  620 
  621   | otherwise = return (Just (hostWayTag ++ "o"))
  622   where
  623     targetFullWays = fullWays (ways dflags)
  624     hostWayTag = case waysTag hostFullWays of
  625                   "" -> ""
  626                   tag -> tag ++ "_"
  627 
  628 normalObjectSuffix :: String
  629 normalObjectSuffix = phaseInputExt StopLn
  630 
  631 data Way' = Normal | Prof | Dyn
  632 
  633 failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
  634 failNonStd dflags srcspan = dieWith dflags srcspan $
  635   text "Cannot load" <+> pprWay' compWay <+>
  636      text "objects when GHC is built" <+> pprWay' ghciWay $$
  637   text "To fix this, either:" $$
  638   text "  (1) Use -fexternal-interpreter, or" $$
  639   buildTwiceMsg
  640     where compWay
  641             | ways dflags `hasWay` WayDyn  = Dyn
  642             | ways dflags `hasWay` WayProf = Prof
  643             | otherwise = Normal
  644           ghciWay
  645             | hostIsDynamic = Dyn
  646             | hostIsProfiled = Prof
  647             | otherwise = Normal
  648           buildTwiceMsg = case (ghciWay, compWay) of
  649             (Normal, Dyn) -> dynamicTooMsg
  650             (Dyn, Normal) -> dynamicTooMsg
  651             _ ->
  652               text "  (2) Build the program twice: once" <+>
  653                 pprWay' ghciWay <> text ", and then" $$
  654               text "      " <> pprWay' compWay <+>
  655                 text "using -osuf to set a different object file suffix."
  656           dynamicTooMsg = text "  (2) Use -dynamic-too," <+>
  657             text "and use -osuf and -dynosuf to set object file suffixes as needed."
  658           pprWay' :: Way' -> SDoc
  659           pprWay' way = text $ case way of
  660             Normal -> "the normal way"
  661             Prof -> "with -prof"
  662             Dyn -> "with -dynamic"
  663 
  664 getLinkDeps :: HscEnv -> HomePackageTable
  665             -> LoaderState
  666             -> Maybe FilePath                   -- replace object suffixes?
  667             -> SrcSpan                          -- for error messages
  668             -> [Module]                         -- If you need these
  669             -> IO ([Linkable], [Linkable], [UnitId])     -- ... then link these first
  670 -- Fails with an IO exception if it can't find enough files
  671 
  672 getLinkDeps hsc_env hpt pls replace_osuf span mods
  673 -- Find all the packages and linkables that a set of modules depends on
  674  = do {
  675         -- 1.  Find the dependent home-pkg-modules/packages from each iface
  676         -- (omitting modules from the interactive package, which is already linked)
  677       ; (mods_s, pkgs_s) <- follow_deps (filterOut isInteractiveModule mods)
  678                                         emptyUniqDSet emptyUniqDSet;
  679 
  680       ; let
  681         -- 2.  Exclude ones already linked
  682         --      Main reason: avoid findModule calls in get_linkable
  683             (mods_needed, mods_got) = partitionEithers (map split_mods mods_s)
  684             pkgs_needed = pkgs_s `minusList` pkgs_loaded pls
  685 
  686             split_mods mod_name =
  687                 let is_linked = find ((== mod_name) . (moduleName . linkableModule)) (objs_loaded pls ++ bcos_loaded pls)
  688                 in case is_linked of
  689                      Just linkable -> Right linkable
  690                      Nothing -> Left mod_name
  691 
  692         -- 3.  For each dependent module, find its linkable
  693         --     This will either be in the HPT or (in the case of one-shot
  694         --     compilation) we may need to use maybe_getFileLinkable
  695       ; let { osuf = objectSuf dflags }
  696       ; lnks_needed <- mapM (get_linkable osuf) mods_needed
  697 
  698       ; return (lnks_needed, mods_got ++ lnks_needed, pkgs_needed) }
  699   where
  700     dflags = hsc_dflags hsc_env
  701 
  702         -- The ModIface contains the transitive closure of the module dependencies
  703         -- within the current package, *except* for boot modules: if we encounter
  704         -- a boot module, we have to find its real interface and discover the
  705         -- dependencies of that.  Hence we need to traverse the dependency
  706         -- tree recursively.  See bug #936, testcase ghci/prog007.
  707     follow_deps :: [Module]             -- modules to follow
  708                 -> UniqDSet ModuleName         -- accum. module dependencies
  709                 -> UniqDSet UnitId          -- accum. package dependencies
  710                 -> IO ([ModuleName], [UnitId]) -- result
  711     follow_deps []     acc_mods acc_pkgs
  712         = return (uniqDSetToList acc_mods, uniqDSetToList acc_pkgs)
  713     follow_deps (mod:mods) acc_mods acc_pkgs
  714         = do
  715           mb_iface <- initIfaceCheck (text "getLinkDeps") hsc_env $
  716                         loadInterface msg mod (ImportByUser NotBoot)
  717           iface <- case mb_iface of
  718                     Maybes.Failed err      -> throwGhcExceptionIO (ProgramError (showSDoc dflags err))
  719                     Maybes.Succeeded iface -> return iface
  720 
  721           when (mi_boot iface == IsBoot) $ link_boot_mod_error mod
  722 
  723           let
  724             pkg = moduleUnit mod
  725             deps  = mi_deps iface
  726             home_unit = hsc_home_unit hsc_env
  727 
  728             pkg_deps = dep_direct_pkgs deps
  729             (boot_deps, mod_deps) = flip partitionWith (Set.toList (dep_direct_mods deps)) $
  730               \case
  731                 GWIB m IsBoot  -> Left m
  732                 GWIB m NotBoot -> Right m
  733 
  734             mod_deps' = filter (not . (`elementOfUniqDSet` acc_mods)) (boot_deps ++ mod_deps)
  735             acc_mods'  = addListToUniqDSet acc_mods (moduleName mod : mod_deps)
  736             acc_pkgs'  = addListToUniqDSet acc_pkgs (Set.toList pkg_deps)
  737           --
  738           if not (isHomeUnit home_unit pkg)
  739              then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg))
  740              else follow_deps (map (mkHomeModule home_unit) mod_deps' ++ mods)
  741                               acc_mods' acc_pkgs'
  742         where
  743             msg = text "need to link module" <+> ppr mod <+>
  744                   text "due to use of Template Haskell"
  745 
  746 
  747     link_boot_mod_error mod =
  748         throwGhcExceptionIO (ProgramError (showSDoc dflags (
  749             text "module" <+> ppr mod <+>
  750             text "cannot be linked; it is only available as a boot module")))
  751 
  752     no_obj :: Outputable a => a -> IO b
  753     no_obj mod = dieWith dflags span $
  754                      text "cannot find object file for module " <>
  755                         quotes (ppr mod) $$
  756                      while_linking_expr
  757 
  758     while_linking_expr = text "while linking an interpreted expression"
  759 
  760         -- This one is a build-system bug
  761 
  762     get_linkable osuf mod_name      -- A home-package module
  763         | Just mod_info <- lookupHpt hpt mod_name
  764         = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))
  765         | otherwise
  766         = do    -- It's not in the HPT because we are in one shot mode,
  767                 -- so use the Finder to get a ModLocation...
  768              let fc = hsc_FC hsc_env
  769              let home_unit = hsc_home_unit hsc_env
  770              let dflags = hsc_dflags hsc_env
  771              let fopts = initFinderOpts dflags
  772              mb_stuff <- findHomeModule fc fopts home_unit mod_name
  773              case mb_stuff of
  774                   Found loc mod -> found loc mod
  775                   _ -> no_obj mod_name
  776         where
  777             found loc mod = do {
  778                 -- ...and then find the linkable for it
  779                mb_lnk <- findObjectLinkableMaybe mod loc ;
  780                case mb_lnk of {
  781                   Nothing  -> no_obj mod ;
  782                   Just lnk -> adjust_linkable lnk
  783               }}
  784 
  785             adjust_linkable lnk
  786                 | Just new_osuf <- replace_osuf = do
  787                         new_uls <- mapM (adjust_ul new_osuf)
  788                                         (linkableUnlinked lnk)
  789                         return lnk{ linkableUnlinked=new_uls }
  790                 | otherwise =
  791                         return lnk
  792 
  793             adjust_ul new_osuf (DotO file) = do
  794                 massert (osuf `isSuffixOf` file)
  795                 let file_base = fromJust (stripExtension osuf file)
  796                     new_file = file_base <.> new_osuf
  797                 ok <- doesFileExist new_file
  798                 if (not ok)
  799                    then dieWith dflags span $
  800                           text "cannot find object file "
  801                                 <> quotes (text new_file) $$ while_linking_expr
  802                    else return (DotO new_file)
  803             adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp)
  804             adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp)
  805             adjust_ul _ l@(BCOs {}) = return l
  806 
  807 
  808 
  809 {- **********************************************************************
  810 
  811               Loading a Decls statement
  812 
  813   ********************************************************************* -}
  814 
  815 loadDecls :: Interp -> HscEnv -> (SrcSpan, Maybe ModuleNameWithIsBoot) -> CompiledByteCode -> IO [(Name, ForeignHValue)]
  816 loadDecls interp hsc_env span cbc@CompiledByteCode{..} = do
  817     -- Initialise the linker (if it's not been done already)
  818     initLoaderState interp hsc_env
  819 
  820     -- Take lock for the actual work.
  821     modifyLoaderState interp $ \pls0 -> do
  822       -- Link the packages and modules required
  823       (pls, ok) <- loadDependencies interp hsc_env pls0 span needed_mods
  824       if failed ok
  825         then throwGhcExceptionIO (ProgramError "")
  826         else do
  827           -- Link the expression itself
  828           let ie = plusNameEnv (itbl_env pls) bc_itbls
  829               ce = closure_env pls
  830 
  831           -- Link the necessary packages and linkables
  832           bco_opts <- initBCOOpts (hsc_dflags hsc_env)
  833           new_bindings <- linkSomeBCOs bco_opts interp ie ce [cbc]
  834           nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings
  835           let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs
  836                          , itbl_env    = ie }
  837           return (pls2, nms_fhvs)
  838   where
  839     free_names = uniqDSetToList $
  840       foldr (unionUniqDSets . bcoFreeNames) emptyUniqDSet bc_bcos
  841 
  842     needed_mods :: [Module]
  843     needed_mods = [ nameModule n | n <- free_names,
  844                     isExternalName n,       -- Names from other modules
  845                     not (isWiredInName n)   -- Exclude wired-in names
  846                   ]                         -- (see note below)
  847     -- Exclude wired-in names because we may not have read
  848     -- their interface files, so getLinkDeps will fail
  849     -- All wired-in names are in the base package, which we link
  850     -- by default, so we can safely ignore them here.
  851 
  852 {- **********************************************************************
  853 
  854               Loading a single module
  855 
  856   ********************************************************************* -}
  857 
  858 loadModule :: Interp -> HscEnv -> Maybe ModuleNameWithIsBoot -> Module -> IO ()
  859 loadModule interp hsc_env mnwib mod = do
  860   initLoaderState interp hsc_env
  861   modifyLoaderState_ interp $ \pls -> do
  862     (pls', ok) <- loadDependencies interp hsc_env pls (noSrcSpan, mnwib) [mod]
  863     if failed ok
  864       then throwGhcExceptionIO (ProgramError "could not load module")
  865       else return pls'
  866 
  867 {- **********************************************************************
  868 
  869                 Link some linkables
  870         The linkables may consist of a mixture of
  871         byte-code modules and object modules
  872 
  873   ********************************************************************* -}
  874 
  875 loadModules :: Interp -> HscEnv -> LoaderState -> [Linkable] -> IO (LoaderState, SuccessFlag)
  876 loadModules interp hsc_env pls linkables
  877   = mask_ $ do  -- don't want to be interrupted by ^C in here
  878 
  879         let (objs, bcos) = partition isObjectLinkable
  880                               (concatMap partitionLinkable linkables)
  881         bco_opts <- initBCOOpts (hsc_dflags hsc_env)
  882 
  883                 -- Load objects first; they can't depend on BCOs
  884         (pls1, ok_flag) <- loadObjects interp hsc_env pls objs
  885 
  886         if failed ok_flag then
  887                 return (pls1, Failed)
  888           else do
  889                 pls2 <- dynLinkBCOs bco_opts interp pls1 bcos
  890                 return (pls2, Succeeded)
  891 
  892 
  893 -- HACK to support f-x-dynamic in the interpreter; no other purpose
  894 partitionLinkable :: Linkable -> [Linkable]
  895 partitionLinkable li
  896    = let li_uls = linkableUnlinked li
  897          li_uls_obj = filter isObject li_uls
  898          li_uls_bco = filter isInterpretable li_uls
  899      in
  900          case (li_uls_obj, li_uls_bco) of
  901             (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj},
  902                            li {linkableUnlinked=li_uls_bco}]
  903             _ -> [li]
  904 
  905 findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
  906 findModuleLinkable_maybe lis mod
  907    = case [LM time nm us | LM time nm us <- lis, nm == mod] of
  908         []   -> Nothing
  909         [li] -> Just li
  910         _    -> pprPanic "findModuleLinkable" (ppr mod)
  911 
  912 linkableInSet :: Linkable -> [Linkable] -> Bool
  913 linkableInSet l objs_loaded =
  914   case findModuleLinkable_maybe objs_loaded (linkableModule l) of
  915         Nothing -> False
  916         Just m  -> linkableTime l == linkableTime m
  917 
  918 
  919 {- **********************************************************************
  920 
  921                 The object-code linker
  922 
  923   ********************************************************************* -}
  924 
  925 -- | Load the object files and link them
  926 --
  927 -- If the interpreter uses dynamic-linking, build a shared library and load it.
  928 -- Otherwise, use the RTS linker.
  929 loadObjects
  930   :: Interp
  931   -> HscEnv
  932   -> LoaderState
  933   -> [Linkable]
  934   -> IO (LoaderState, SuccessFlag)
  935 loadObjects interp hsc_env pls objs = do
  936         let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
  937             pls1                     = pls { objs_loaded = objs_loaded' }
  938             unlinkeds                = concatMap linkableUnlinked new_objs
  939             wanted_objs              = map nameOfObject unlinkeds
  940 
  941         if interpreterDynamic interp
  942             then do pls2 <- dynLoadObjs interp hsc_env pls1 wanted_objs
  943                     return (pls2, Succeeded)
  944             else do mapM_ (loadObj interp) wanted_objs
  945 
  946                     -- Link them all together
  947                     ok <- resolveObjs interp
  948 
  949                     -- If resolving failed, unload all our
  950                     -- object modules and carry on
  951                     if succeeded ok then
  952                             return (pls1, Succeeded)
  953                       else do
  954                             pls2 <- unload_wkr interp [] pls1
  955                             return (pls2, Failed)
  956 
  957 
  958 -- | Create a shared library containing the given object files and load it.
  959 dynLoadObjs :: Interp -> HscEnv -> LoaderState -> [FilePath] -> IO LoaderState
  960 dynLoadObjs _      _       pls                           []   = return pls
  961 dynLoadObjs interp hsc_env pls@LoaderState{..} objs = do
  962     let unit_env = hsc_unit_env hsc_env
  963     let dflags   = hsc_dflags hsc_env
  964     let logger   = hsc_logger hsc_env
  965     let tmpfs    = hsc_tmpfs hsc_env
  966     let platform = ue_platform unit_env
  967     let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ]
  968     let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ]
  969     (soFile, libPath , libName) <-
  970       newTempLibName logger tmpfs (tmpDir dflags) TFL_CurrentModule (platformSOExt platform)
  971     let
  972         dflags2 = dflags {
  973                       -- We don't want the original ldInputs in
  974                       -- (they're already linked in), but we do want
  975                       -- to link against previous dynLoadObjs
  976                       -- libraries if there were any, so that the linker
  977                       -- can resolve dependencies when it loads this
  978                       -- library.
  979                       ldInputs =
  980                            concatMap (\l -> [ Option ("-l" ++ l) ])
  981                                      (nub $ snd <$> temp_sos)
  982                         ++ concatMap (\lp -> Option ("-L" ++ lp)
  983                                           : if useXLinkerRPath dflags (platformOS platform)
  984                                             then [ Option "-Xlinker"
  985                                                  , Option "-rpath"
  986                                                  , Option "-Xlinker"
  987                                                  , Option lp ]
  988                                             else [])
  989                                      (nub $ fst <$> temp_sos)
  990                         ++ concatMap
  991                              (\lp -> Option ("-L" ++ lp)
  992                                   : if useXLinkerRPath dflags (platformOS platform)
  993                                     then [ Option "-Xlinker"
  994                                          , Option "-rpath"
  995                                          , Option "-Xlinker"
  996                                          , Option lp ]
  997                                     else [])
  998                              minus_big_ls
  999                         -- See Note [-Xlinker -rpath vs -Wl,-rpath]
 1000                         ++ map (\l -> Option ("-l" ++ l)) minus_ls,
 1001                       -- Add -l options and -L options from dflags.
 1002                       --
 1003                       -- When running TH for a non-dynamic way, we still
 1004                       -- need to make -l flags to link against the dynamic
 1005                       -- libraries, so we need to add WayDyn to ways.
 1006                       --
 1007                       -- Even if we're e.g. profiling, we still want
 1008                       -- the vanilla dynamic libraries, so we set the
 1009                       -- ways / build tag to be just WayDyn.
 1010                       targetWays_ = Set.singleton WayDyn,
 1011                       outputFile_ = Just soFile
 1012                   }
 1013     -- link all "loaded packages" so symbols in those can be resolved
 1014     -- Note: We are loading packages with local scope, so to see the
 1015     -- symbols in this link we must link all loaded packages again.
 1016     linkDynLib logger tmpfs dflags2 unit_env objs pkgs_loaded
 1017 
 1018     -- if we got this far, extend the lifetime of the library file
 1019     changeTempFilesLifetime tmpfs TFL_GhcSession [soFile]
 1020     m <- loadDLL interp soFile
 1021     case m of
 1022         Nothing -> return $! pls { temp_sos = (libPath, libName) : temp_sos }
 1023         Just err -> linkFail msg err
 1024   where
 1025     msg = "GHC.Linker.Loader.dynLoadObjs: Loading temp shared object failed"
 1026 
 1027 rmDupLinkables :: [Linkable]    -- Already loaded
 1028                -> [Linkable]    -- New linkables
 1029                -> ([Linkable],  -- New loaded set (including new ones)
 1030                    [Linkable])  -- New linkables (excluding dups)
 1031 rmDupLinkables already ls
 1032   = go already [] ls
 1033   where
 1034     go already extras [] = (already, extras)
 1035     go already extras (l:ls)
 1036         | linkableInSet l already = go already     extras     ls
 1037         | otherwise               = go (l:already) (l:extras) ls
 1038 
 1039 {- **********************************************************************
 1040 
 1041                 The byte-code linker
 1042 
 1043   ********************************************************************* -}
 1044 
 1045 
 1046 dynLinkBCOs :: BCOOpts -> Interp -> LoaderState -> [Linkable] -> IO LoaderState
 1047 dynLinkBCOs bco_opts interp pls bcos = do
 1048 
 1049         let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
 1050             pls1                     = pls { bcos_loaded = bcos_loaded' }
 1051             unlinkeds :: [Unlinked]
 1052             unlinkeds                = concatMap linkableUnlinked new_bcos
 1053 
 1054             cbcs :: [CompiledByteCode]
 1055             cbcs      = map byteCodeOfObject unlinkeds
 1056 
 1057 
 1058             ies        = map bc_itbls cbcs
 1059             gce       = closure_env pls
 1060             final_ie  = foldr plusNameEnv (itbl_env pls) ies
 1061 
 1062         names_and_refs <- linkSomeBCOs bco_opts interp final_ie gce cbcs
 1063 
 1064         -- We only want to add the external ones to the ClosureEnv
 1065         let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs
 1066 
 1067         -- Immediately release any HValueRefs we're not going to add
 1068         freeHValueRefs interp (map snd to_drop)
 1069         -- Wrap finalizers on the ones we want to keep
 1070         new_binds <- makeForeignNamedHValueRefs interp to_add
 1071 
 1072         return pls1 { closure_env = extendClosureEnv gce new_binds,
 1073                       itbl_env    = final_ie }
 1074 
 1075 -- Link a bunch of BCOs and return references to their values
 1076 linkSomeBCOs :: BCOOpts
 1077              -> Interp
 1078              -> ItblEnv
 1079              -> ClosureEnv
 1080              -> [CompiledByteCode]
 1081              -> IO [(Name,HValueRef)]
 1082                         -- The returned HValueRefs are associated 1-1 with
 1083                         -- the incoming unlinked BCOs.  Each gives the
 1084                         -- value of the corresponding unlinked BCO
 1085 
 1086 linkSomeBCOs bco_opts interp ie ce mods = foldr fun do_link mods []
 1087  where
 1088   fun CompiledByteCode{..} inner accum =
 1089     case bc_breaks of
 1090       Nothing -> inner ((panic "linkSomeBCOs: no break array", bc_bcos) : accum)
 1091       Just mb -> withForeignRef (modBreaks_flags mb) $ \breakarray ->
 1092                    inner ((breakarray, bc_bcos) : accum)
 1093 
 1094   do_link [] = return []
 1095   do_link mods = do
 1096     let flat = [ (breakarray, bco) | (breakarray, bcos) <- mods, bco <- bcos ]
 1097         names = map (unlinkedBCOName . snd) flat
 1098         bco_ix = mkNameEnv (zip names [0..])
 1099     resolved <- sequence [ linkBCO interp ie ce bco_ix breakarray bco
 1100                          | (breakarray, bco) <- flat ]
 1101     hvrefs <- createBCOs interp bco_opts resolved
 1102     return (zip names hvrefs)
 1103 
 1104 -- | Useful to apply to the result of 'linkSomeBCOs'
 1105 makeForeignNamedHValueRefs
 1106   :: Interp -> [(Name,HValueRef)] -> IO [(Name,ForeignHValue)]
 1107 makeForeignNamedHValueRefs interp bindings =
 1108   mapM (\(n, hvref) -> (n,) <$> mkFinalizedHValue interp hvref) bindings
 1109 
 1110 {- **********************************************************************
 1111 
 1112                 Unload some object modules
 1113 
 1114   ********************************************************************* -}
 1115 
 1116 -- ---------------------------------------------------------------------------
 1117 -- | Unloading old objects ready for a new compilation sweep.
 1118 --
 1119 -- The compilation manager provides us with a list of linkables that it
 1120 -- considers \"stable\", i.e. won't be recompiled this time around.  For
 1121 -- each of the modules current linked in memory,
 1122 --
 1123 --   * if the linkable is stable (and it's the same one -- the user may have
 1124 --     recompiled the module on the side), we keep it,
 1125 --
 1126 --   * otherwise, we unload it.
 1127 --
 1128 --   * we also implicitly unload all temporary bindings at this point.
 1129 --
 1130 unload
 1131   :: Interp
 1132   -> HscEnv
 1133   -> [Linkable] -- ^ The linkables to *keep*.
 1134   -> IO ()
 1135 unload interp hsc_env linkables
 1136   = mask_ $ do -- mask, so we're safe from Ctrl-C in here
 1137 
 1138         -- Initialise the linker (if it's not been done already)
 1139         initLoaderState interp hsc_env
 1140 
 1141         new_pls
 1142             <- modifyLoaderState interp $ \pls -> do
 1143                  pls1 <- unload_wkr interp linkables pls
 1144                  return (pls1, pls1)
 1145 
 1146         let logger = hsc_logger hsc_env
 1147         debugTraceMsg logger 3 $
 1148           text "unload: retaining objs" <+> ppr (objs_loaded new_pls)
 1149         debugTraceMsg logger 3 $
 1150           text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls)
 1151         return ()
 1152 
 1153 unload_wkr
 1154   :: Interp
 1155   -> [Linkable]                -- stable linkables
 1156   -> LoaderState
 1157   -> IO LoaderState
 1158 -- Does the core unload business
 1159 -- (the wrapper blocks exceptions and deals with the LS get and put)
 1160 
 1161 unload_wkr interp keep_linkables pls@LoaderState{..}  = do
 1162   -- NB. careful strictness here to avoid keeping the old LS when
 1163   -- we're unloading some code.  -fghci-leak-check with the tests in
 1164   -- testsuite/ghci can detect space leaks here.
 1165 
 1166   let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable keep_linkables
 1167 
 1168       discard keep l = not (linkableInSet l keep)
 1169 
 1170       (objs_to_unload, remaining_objs_loaded) =
 1171          partition (discard objs_to_keep) objs_loaded
 1172       (bcos_to_unload, remaining_bcos_loaded) =
 1173          partition (discard bcos_to_keep) bcos_loaded
 1174 
 1175   mapM_ unloadObjs objs_to_unload
 1176   mapM_ unloadObjs bcos_to_unload
 1177 
 1178   -- If we unloaded any object files at all, we need to purge the cache
 1179   -- of lookupSymbol results.
 1180   when (not (null (objs_to_unload ++
 1181                    filter (not . null . linkableObjs) bcos_to_unload))) $
 1182     purgeLookupSymbolCache interp
 1183 
 1184   let !bcos_retained = mkModuleSet $ map linkableModule remaining_bcos_loaded
 1185 
 1186       -- Note that we want to remove all *local*
 1187       -- (i.e. non-isExternal) names too (these are the
 1188       -- temporary bindings from the command line).
 1189       keep_name :: (Name, a) -> Bool
 1190       keep_name (n,_) = isExternalName n &&
 1191                         nameModule n `elemModuleSet` bcos_retained
 1192 
 1193       itbl_env'     = filterNameEnv keep_name itbl_env
 1194       closure_env'  = filterNameEnv keep_name closure_env
 1195 
 1196       !new_pls = pls { itbl_env = itbl_env',
 1197                        closure_env = closure_env',
 1198                        bcos_loaded = remaining_bcos_loaded,
 1199                        objs_loaded = remaining_objs_loaded }
 1200 
 1201   return new_pls
 1202   where
 1203     unloadObjs :: Linkable -> IO ()
 1204     unloadObjs lnk
 1205       | interpreterDynamic interp = return ()
 1206         -- We don't do any cleanup when linking objects with the
 1207         -- dynamic linker.  Doing so introduces extra complexity for
 1208         -- not much benefit.
 1209 
 1210       | otherwise
 1211       = mapM_ (unloadObj interp) [f | DotO f <- linkableUnlinked lnk]
 1212                 -- The components of a BCO linkable may contain
 1213                 -- dot-o files.  Which is very confusing.
 1214                 --
 1215                 -- But the BCO parts can be unlinked just by
 1216                 -- letting go of them (plus of course depopulating
 1217                 -- the symbol table which is done in the main body)
 1218 
 1219 -- If this package is already part of the GHCi binary, we'll already
 1220 -- have the right DLLs for this package loaded, so don't try to
 1221 -- load them again.
 1222 --
 1223 -- But on Win32 we must load them 'again'; doing so is a harmless no-op
 1224 -- as far as the loader is concerned, but it does initialise the list
 1225 -- of DLL handles that rts/Linker.c maintains, and that in turn is
 1226 -- used by lookupSymbol.  So we must call addDLL for each library
 1227 -- just to get the DLL handle into the list.
 1228 partOfGHCi :: [PackageName]
 1229 partOfGHCi
 1230  | isWindowsHost || isDarwinHost = []
 1231  | otherwise = map (PackageName . mkFastString)
 1232                    ["base", "template-haskell", "editline"]
 1233 
 1234 showLS :: LibrarySpec -> String
 1235 showLS (Objects nms)  = "(static) [" ++ intercalate ", " nms ++ "]"
 1236 showLS (Archive nm)   = "(static archive) " ++ nm
 1237 showLS (DLL nm)       = "(dynamic) " ++ nm
 1238 showLS (DLLPath nm)   = "(dynamic) " ++ nm
 1239 showLS (Framework nm) = "(framework) " ++ nm
 1240 
 1241 -- | Load exactly the specified packages, and their dependents (unless of
 1242 -- course they are already loaded).  The dependents are loaded
 1243 -- automatically, and it doesn't matter what order you specify the input
 1244 -- packages.
 1245 --
 1246 loadPackages :: Interp -> HscEnv -> [UnitId] -> IO ()
 1247 -- NOTE: in fact, since each module tracks all the packages it depends on,
 1248 --       we don't really need to use the package-config dependencies.
 1249 --
 1250 -- However we do need the package-config stuff (to find aux libs etc),
 1251 -- and following them lets us load libraries in the right order, which
 1252 -- perhaps makes the error message a bit more localised if we get a link
 1253 -- failure.  So the dependency walking code is still here.
 1254 
 1255 loadPackages interp hsc_env new_pkgs = do
 1256   -- It's probably not safe to try to load packages concurrently, so we take
 1257   -- a lock.
 1258   initLoaderState interp hsc_env
 1259   modifyLoaderState_ interp $ \pls ->
 1260     loadPackages' interp hsc_env new_pkgs pls
 1261 
 1262 loadPackages' :: Interp -> HscEnv -> [UnitId] -> LoaderState -> IO LoaderState
 1263 loadPackages' interp hsc_env new_pks pls = do
 1264     (pkgs', hs_objs, non_hs_objs) <- link (pkgs_loaded pls) new_pks
 1265     return $! pls { pkgs_loaded = pkgs'
 1266                   , hs_objs_loaded = hs_objs ++ hs_objs_loaded pls
 1267                   , non_hs_objs_loaded = non_hs_objs ++ non_hs_objs_loaded pls }
 1268   where
 1269      link :: [UnitId] -> [UnitId] -> IO ([UnitId], [LibrarySpec], [LibrarySpec])
 1270      link pkgs new_pkgs =
 1271          foldM link_one (pkgs, [],[]) new_pkgs
 1272 
 1273      link_one (pkgs, acc_hs, acc_non_hs) new_pkg
 1274         | new_pkg `elem` pkgs   -- Already linked
 1275         = return (pkgs, acc_hs, acc_non_hs)
 1276 
 1277         | Just pkg_cfg <- lookupUnitId (hsc_units hsc_env) new_pkg
 1278         = do {  -- Link dependents first
 1279                (pkgs', hs_cls', extra_cls') <- link pkgs (unitDepends pkg_cfg)
 1280                 -- Now link the package itself
 1281              ; (hs_cls, extra_cls) <- loadPackage interp hsc_env pkg_cfg
 1282              ; return (new_pkg : pkgs', acc_hs ++ hs_cls ++ hs_cls', acc_non_hs ++ extra_cls ++ extra_cls') }
 1283 
 1284         | otherwise
 1285         = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg)))
 1286 
 1287 
 1288 loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ([LibrarySpec], [LibrarySpec])
 1289 loadPackage interp hsc_env pkg
 1290    = do
 1291         let dflags    = hsc_dflags hsc_env
 1292         let logger    = hsc_logger hsc_env
 1293             platform  = targetPlatform dflags
 1294             is_dyn    = interpreterDynamic interp
 1295             dirs | is_dyn    = map ST.unpack $ Packages.unitLibraryDynDirs pkg
 1296                  | otherwise = map ST.unpack $ Packages.unitLibraryDirs pkg
 1297 
 1298         let hs_libs   = map ST.unpack $ Packages.unitLibraries pkg
 1299             -- The FFI GHCi import lib isn't needed as
 1300             -- GHC.Linker.Loader + rts/Linker.c link the
 1301             -- interpreted references to FFI to the compiled FFI.
 1302             -- We therefore filter it out so that we don't get
 1303             -- duplicate symbol errors.
 1304             hs_libs'  =  filter ("HSffi" /=) hs_libs
 1305 
 1306         -- Because of slight differences between the GHC dynamic linker and
 1307         -- the native system linker some packages have to link with a
 1308         -- different list of libraries when using GHCi. Examples include: libs
 1309         -- that are actually gnu ld scripts, and the possibility that the .a
 1310         -- libs do not exactly match the .so/.dll equivalents. So if the
 1311         -- package file provides an "extra-ghci-libraries" field then we use
 1312         -- that instead of the "extra-libraries" field.
 1313             extdeplibs = map ST.unpack (if null (Packages.unitExtDepLibsGhc pkg)
 1314                                       then Packages.unitExtDepLibsSys pkg
 1315                                       else Packages.unitExtDepLibsGhc pkg)
 1316             linkerlibs = [ lib | '-':'l':lib <- (map ST.unpack $ Packages.unitLinkerOptions pkg) ]
 1317             extra_libs = extdeplibs ++ linkerlibs
 1318 
 1319         -- See Note [Fork/Exec Windows]
 1320         gcc_paths <- getGCCPaths logger dflags (platformOS platform)
 1321         dirs_env <- addEnvPaths "LIBRARY_PATH" dirs
 1322 
 1323         hs_classifieds
 1324            <- mapM (locateLib interp hsc_env True  dirs_env gcc_paths) hs_libs'
 1325         extra_classifieds
 1326            <- mapM (locateLib interp hsc_env False dirs_env gcc_paths) extra_libs
 1327         let classifieds = hs_classifieds ++ extra_classifieds
 1328 
 1329         -- Complication: all the .so's must be loaded before any of the .o's.
 1330         let known_dlls = [ dll  | DLLPath dll    <- classifieds ]
 1331             dlls       = [ dll  | DLL dll        <- classifieds ]
 1332             objs       = [ obj  | Objects objs    <- classifieds
 1333                                 , obj <- objs ]
 1334             archs      = [ arch | Archive arch   <- classifieds ]
 1335 
 1336         -- Add directories to library search paths
 1337         let dll_paths  = map takeDirectory known_dlls
 1338             all_paths  = nub $ map normalise $ dll_paths ++ dirs
 1339         all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths
 1340         pathCache <- mapM (addLibrarySearchPath interp) all_paths_env
 1341 
 1342         maybePutSDoc logger
 1343             (text "Loading unit " <> pprUnitInfoForUser pkg <> text " ... ")
 1344 
 1345         -- See comments with partOfGHCi
 1346 #if defined(CAN_LOAD_DLL)
 1347         when (unitPackageName pkg `notElem` partOfGHCi) $ do
 1348             loadFrameworks interp platform pkg
 1349             -- See Note [Crash early load_dyn and locateLib]
 1350             -- Crash early if can't load any of `known_dlls`
 1351             mapM_ (load_dyn interp hsc_env True) known_dlls
 1352             -- For remaining `dlls` crash early only when there is surely
 1353             -- no package's DLL around ... (not is_dyn)
 1354             mapM_ (load_dyn interp hsc_env (not is_dyn) . platformSOName platform) dlls
 1355 #endif
 1356         -- After loading all the DLLs, we can load the static objects.
 1357         -- Ordering isn't important here, because we do one final link
 1358         -- step to resolve everything.
 1359         mapM_ (loadObj interp) objs
 1360         mapM_ (loadArchive interp) archs
 1361 
 1362         maybePutStr logger "linking ... "
 1363         ok <- resolveObjs interp
 1364 
 1365         -- DLLs are loaded, reset the search paths
 1366         -- Import libraries will be loaded via loadArchive so only
 1367         -- reset the DLL search path after all archives are loaded
 1368         -- as well.
 1369         mapM_ (removeLibrarySearchPath interp) $ reverse pathCache
 1370 
 1371         if succeeded ok
 1372            then do
 1373              maybePutStrLn logger "done."
 1374              return (hs_classifieds, extra_classifieds)
 1375            else let errmsg = text "unable to load unit `"
 1376                              <> pprUnitInfoForUser pkg <> text "'"
 1377                  in throwGhcExceptionIO (InstallationError (showSDoc dflags errmsg))
 1378 
 1379 {-
 1380 Note [Crash early load_dyn and locateLib]
 1381 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1382 If a package is "normal" (exposes it's code from more than zero Haskell
 1383 modules, unlike e.g. that in ghcilink004) and is built "dyn" way, then
 1384 it has it's code compiled and linked into the DLL, which GHCi linker picks
 1385 when loading the package's code (see the big comment in the beginning of
 1386 `locateLib`).
 1387 
 1388 When loading DLLs, GHCi linker simply calls the system's `dlopen` or
 1389 `LoadLibrary` APIs. This is quite different from the case when GHCi linker
 1390 loads an object file or static library. When loading an object file or static
 1391 library GHCi linker parses them and resolves all symbols "manually".
 1392 These object file or static library may reference some external symbols
 1393 defined in some external DLLs. And GHCi should know which these
 1394 external DLLs are.
 1395 
 1396 But when GHCi loads a DLL, it's the *system* linker who manages all
 1397 the necessary dependencies, and it is able to load this DLL not having
 1398 any extra info. Thus we don't *have to* crash in this case even if we
 1399 are unable to load any supposed dependencies explicitly.
 1400 
 1401 Suppose during GHCi session a client of the package wants to
 1402 `foreign import` a symbol which isn't exposed by the package DLL, but
 1403 is exposed by such an external (dependency) DLL.
 1404 If the DLL isn't *explicitly* loaded because `load_dyn` failed to do
 1405 this, then the client code eventually crashes because the GHCi linker
 1406 isn't able to locate this symbol (GHCi linker maintains a list of
 1407 explicitly loaded DLLs it looks into when trying to find a symbol).
 1408 
 1409 This is why we still should try to load all the dependency DLLs
 1410 even though we know that the system linker loads them implicitly when
 1411 loading the package DLL.
 1412 
 1413 Why we still keep the `crash_early` opportunity then not allowing such
 1414 a permissive behaviour for any DLLs? Well, we, perhaps, improve a user
 1415 experience in some cases slightly.
 1416 
 1417 But if it happens there exist other corner cases where our current
 1418 usage of `crash_early` flag is overly restrictive, we may lift the
 1419 restriction very easily.
 1420 -}
 1421 
 1422 -- we have already searched the filesystem; the strings passed to load_dyn
 1423 -- can be passed directly to loadDLL.  They are either fully-qualified
 1424 -- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so").  In the latter case,
 1425 -- loadDLL is going to search the system paths to find the library.
 1426 load_dyn :: Interp -> HscEnv -> Bool -> FilePath -> IO ()
 1427 load_dyn interp hsc_env crash_early dll = do
 1428   r <- loadDLL interp dll
 1429   case r of
 1430     Nothing  -> return ()
 1431     Just err ->
 1432       if crash_early
 1433         then cmdLineErrorIO err
 1434         else
 1435           when (diag_wopt Opt_WarnMissedExtraSharedLib diag_opts)
 1436             $ logMsg logger
 1437                 (mkMCDiagnostic diag_opts $ WarningWithFlag Opt_WarnMissedExtraSharedLib)
 1438                   noSrcSpan $ withPprStyle defaultUserStyle (note err)
 1439   where
 1440     diag_opts = initDiagOpts (hsc_dflags hsc_env)
 1441     logger = hsc_logger hsc_env
 1442     note err = vcat $ map text
 1443       [ err
 1444       , "It's OK if you don't want to use symbols from it directly."
 1445       , "(the package DLL is loaded by the system linker"
 1446       , " which manages dependencies by itself)." ]
 1447 
 1448 loadFrameworks :: Interp -> Platform -> UnitInfo -> IO ()
 1449 loadFrameworks interp platform pkg
 1450     = when (platformUsesFrameworks platform) $ mapM_ load frameworks
 1451   where
 1452     fw_dirs    = map ST.unpack $ Packages.unitExtDepFrameworkDirs pkg
 1453     frameworks = map ST.unpack $ Packages.unitExtDepFrameworks pkg
 1454 
 1455     load fw = do  r <- loadFramework interp fw_dirs fw
 1456                   case r of
 1457                     Nothing  -> return ()
 1458                     Just err -> cmdLineErrorIO ("can't load framework: "
 1459                                                 ++ fw ++ " (" ++ err ++ ")" )
 1460 
 1461 -- Try to find an object file for a given library in the given paths.
 1462 -- If it isn't present, we assume that addDLL in the RTS can find it,
 1463 -- which generally means that it should be a dynamic library in the
 1464 -- standard system search path.
 1465 -- For GHCi we tend to prefer dynamic libraries over static ones as
 1466 -- they are easier to load and manage, have less overhead.
 1467 locateLib
 1468   :: Interp
 1469   -> HscEnv
 1470   -> Bool
 1471   -> [FilePath]
 1472   -> [FilePath]
 1473   -> String
 1474   -> IO LibrarySpec
 1475 locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib
 1476   | not is_hs
 1477     -- For non-Haskell libraries (e.g. gmp, iconv):
 1478     --   first look in library-dirs for a dynamic library (on User paths only)
 1479     --   (libfoo.so)
 1480     --   then  try looking for import libraries on Windows (on User paths only)
 1481     --   (.dll.a, .lib)
 1482     --   first look in library-dirs for a dynamic library (on GCC paths only)
 1483     --   (libfoo.so)
 1484     --   then  check for system dynamic libraries (e.g. kernel32.dll on windows)
 1485     --   then  try looking for import libraries on Windows (on GCC paths only)
 1486     --   (.dll.a, .lib)
 1487     --   then  look in library-dirs for a static library (libfoo.a)
 1488     --   then look in library-dirs and inplace GCC for a dynamic library (libfoo.so)
 1489     --   then  try looking for import libraries on Windows (.dll.a, .lib)
 1490     --   then  look in library-dirs and inplace GCC for a static library (libfoo.a)
 1491     --   then  try "gcc --print-file-name" to search gcc's search path
 1492     --       for a dynamic library (#5289)
 1493     --   otherwise, assume loadDLL can find it
 1494     --
 1495     --   The logic is a bit complicated, but the rationale behind it is that
 1496     --   loading a shared library for us is O(1) while loading an archive is
 1497     --   O(n). Loading an import library is also O(n) so in general we prefer
 1498     --   shared libraries because they are simpler and faster.
 1499     --
 1500   =
 1501 #if defined(CAN_LOAD_DLL)
 1502     findDll   user `orElse`
 1503 #endif
 1504     tryImpLib user `orElse`
 1505 #if defined(CAN_LOAD_DLL)
 1506     findDll   gcc  `orElse`
 1507     findSysDll     `orElse`
 1508 #endif
 1509     tryImpLib gcc  `orElse`
 1510     findArchive    `orElse`
 1511     tryGcc         `orElse`
 1512     assumeDll
 1513 
 1514   | loading_dynamic_hs_libs -- search for .so libraries first.
 1515   = findHSDll     `orElse`
 1516     findDynObject `orElse`
 1517     assumeDll
 1518 
 1519   | otherwise
 1520     -- use HSfoo.{o,p_o} if it exists, otherwise fallback to libHSfoo{,_p}.a
 1521   = findObject  `orElse`
 1522     findArchive `orElse`
 1523     assumeDll
 1524 
 1525    where
 1526      dflags = hsc_dflags hsc_env
 1527      logger = hsc_logger hsc_env
 1528      diag_opts = initDiagOpts dflags
 1529      dirs   = lib_dirs ++ gcc_dirs
 1530      gcc    = False
 1531      user   = True
 1532 
 1533      obj_file
 1534        | is_hs && loading_profiled_hs_libs = lib <.> "p_o"
 1535        | otherwise = lib <.> "o"
 1536      dyn_obj_file = lib <.> "dyn_o"
 1537      arch_files = [ "lib" ++ lib ++ lib_tag <.> "a"
 1538                   , lib <.> "a" -- native code has no lib_tag
 1539                   , "lib" ++ lib, lib
 1540                   ]
 1541      lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else ""
 1542 
 1543      loading_profiled_hs_libs = interpreterProfiled interp
 1544      loading_dynamic_hs_libs  = interpreterDynamic  interp
 1545 
 1546      import_libs  = [ lib <.> "lib"           , "lib" ++ lib <.> "lib"
 1547                     , "lib" ++ lib <.> "dll.a", lib <.> "dll.a"
 1548                     ]
 1549 
 1550      hs_dyn_lib_name = lib ++ dynLibSuffix (ghcNameVersion dflags)
 1551      hs_dyn_lib_file = platformHsSOName platform hs_dyn_lib_name
 1552 
 1553      so_name     = platformSOName platform lib
 1554      lib_so_name = "lib" ++ so_name
 1555      dyn_lib_file = case (arch, os) of
 1556                              (ArchX86_64, OSSolaris2) -> "64" </> so_name
 1557                              _ -> so_name
 1558 
 1559      findObject    = liftM (fmap $ Objects . (:[]))  $ findFile dirs obj_file
 1560      findDynObject = liftM (fmap $ Objects . (:[]))  $ findFile dirs dyn_obj_file
 1561      findArchive   = let local name = liftM (fmap Archive) $ findFile dirs name
 1562                      in  apply (map local arch_files)
 1563      findHSDll     = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file
 1564      findDll    re = let dirs' = if re == user then lib_dirs else gcc_dirs
 1565                      in liftM (fmap DLLPath) $ findFile dirs' dyn_lib_file
 1566      findSysDll    = fmap (fmap $ DLL . dropExtension . takeFileName) $
 1567                         findSystemLibrary interp so_name
 1568      tryGcc        = let search   = searchForLibUsingGcc logger dflags
 1569                          dllpath  = liftM (fmap DLLPath)
 1570                          short    = dllpath $ search so_name lib_dirs
 1571                          full     = dllpath $ search lib_so_name lib_dirs
 1572                          gcc name = liftM (fmap Archive) $ search name lib_dirs
 1573                          files    = import_libs ++ arch_files
 1574                          dlls     = [short, full]
 1575                          archives = map gcc files
 1576                      in apply $
 1577 #if defined(CAN_LOAD_DLL)
 1578                           dlls ++
 1579 #endif
 1580                           archives
 1581      tryImpLib re = case os of
 1582                        OSMinGW32 ->
 1583                         let dirs' = if re == user then lib_dirs else gcc_dirs
 1584                             implib name = liftM (fmap Archive) $
 1585                                             findFile dirs' name
 1586                         in apply (map implib import_libs)
 1587                        _         -> return Nothing
 1588 
 1589      -- TH Makes use of the interpreter so this failure is not obvious.
 1590      -- So we are nice and warn/inform users why we fail before we do.
 1591      -- But only for haskell libraries, as C libraries don't have a
 1592      -- profiling/non-profiling distinction to begin with.
 1593      assumeDll
 1594       | is_hs
 1595       , not loading_dynamic_hs_libs
 1596       , interpreterProfiled interp
 1597       = do
 1598           let diag = mkMCDiagnostic diag_opts WarningWithoutFlag
 1599           logMsg logger diag noSrcSpan $ withPprStyle defaultErrStyle $
 1600             text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$
 1601               text " \tTrying dynamic library instead. If this fails try to rebuild" <+>
 1602               text "libraries with profiling support."
 1603           return (DLL lib)
 1604       | otherwise = return (DLL lib)
 1605      infixr `orElse`
 1606      f `orElse` g = f >>= maybe g return
 1607 
 1608      apply :: [IO (Maybe a)] -> IO (Maybe a)
 1609      apply []     = return Nothing
 1610      apply (x:xs) = do x' <- x
 1611                        if isJust x'
 1612                           then return x'
 1613                           else apply xs
 1614 
 1615      platform = targetPlatform dflags
 1616      arch = platformArch platform
 1617      os = platformOS platform
 1618 
 1619 searchForLibUsingGcc :: Logger -> DynFlags -> String -> [FilePath] -> IO (Maybe FilePath)
 1620 searchForLibUsingGcc logger dflags so dirs = do
 1621    -- GCC does not seem to extend the library search path (using -L) when using
 1622    -- --print-file-name. So instead pass it a new base location.
 1623    str <- askLd logger dflags (map (FileOption "-B") dirs
 1624                           ++ [Option "--print-file-name", Option so])
 1625    let file = case lines str of
 1626                 []  -> ""
 1627                 l:_ -> l
 1628    if (file == so)
 1629       then return Nothing
 1630       else do b <- doesFileExist file -- file could be a folder (see #16063)
 1631               return (if b then Just file else Nothing)
 1632 
 1633 -- | Retrieve the list of search directory GCC and the System use to find
 1634 --   libraries and components. See Note [Fork/Exec Windows].
 1635 getGCCPaths :: Logger -> DynFlags -> OS -> IO [FilePath]
 1636 getGCCPaths logger dflags os
 1637   = case os of
 1638       OSMinGW32 ->
 1639         do gcc_dirs <- getGccSearchDirectory logger dflags "libraries"
 1640            sys_dirs <- getSystemDirectories
 1641            return $ nub $ gcc_dirs ++ sys_dirs
 1642       _         -> return []
 1643 
 1644 -- | Cache for the GCC search directories as this can't easily change
 1645 --   during an invocation of GHC. (Maybe with some env. variable but we'll)
 1646 --   deal with that highly unlikely scenario then.
 1647 {-# NOINLINE gccSearchDirCache #-}
 1648 gccSearchDirCache :: IORef [(String, [String])]
 1649 gccSearchDirCache = unsafePerformIO $ newIORef []
 1650 
 1651 -- Note [Fork/Exec Windows]
 1652 -- ~~~~~~~~~~~~~~~~~~~~~~~~
 1653 -- fork/exec is expensive on Windows, for each time we ask GCC for a library we
 1654 -- have to eat the cost of af least 3 of these: gcc -> real_gcc -> cc1.
 1655 -- So instead get a list of location that GCC would search and use findDirs
 1656 -- which hopefully is written in an optimized mannor to take advantage of
 1657 -- caching. At the very least we remove the overhead of the fork/exec and waits
 1658 -- which dominate a large percentage of startup time on Windows.
 1659 getGccSearchDirectory :: Logger -> DynFlags -> String -> IO [FilePath]
 1660 getGccSearchDirectory logger dflags key = do
 1661     cache <- readIORef gccSearchDirCache
 1662     case lookup key cache of
 1663       Just x  -> return x
 1664       Nothing -> do
 1665         str <- askLd logger dflags [Option "--print-search-dirs"]
 1666         let line = dropWhile isSpace str
 1667             name = key ++ ": ="
 1668         if null line
 1669           then return []
 1670           else do let val = split $ find name line
 1671                   dirs <- filterM doesDirectoryExist val
 1672                   modifyIORef' gccSearchDirCache ((key, dirs):)
 1673                   return val
 1674       where split :: FilePath -> [FilePath]
 1675             split r = case break (==';') r of
 1676                         (s, []    ) -> [s]
 1677                         (s, (_:xs)) -> s : split xs
 1678 
 1679             find :: String -> String -> String
 1680             find r x = let lst = lines x
 1681                            val = filter (r `isPrefixOf`) lst
 1682                        in if null val
 1683                              then []
 1684                              else case break (=='=') (head val) of
 1685                                      (_ , [])    -> []
 1686                                      (_, (_:xs)) -> xs
 1687 
 1688 -- | Get a list of system search directories, this to alleviate pressure on
 1689 -- the findSysDll function.
 1690 getSystemDirectories :: IO [FilePath]
 1691 #if defined(mingw32_HOST_OS)
 1692 getSystemDirectories = fmap (:[]) getSystemDirectory
 1693 #else
 1694 getSystemDirectories = return []
 1695 #endif
 1696 
 1697 -- | Merge the given list of paths with those in the environment variable
 1698 --   given. If the variable does not exist then just return the identity.
 1699 addEnvPaths :: String -> [String] -> IO [String]
 1700 addEnvPaths name list
 1701   = do -- According to POSIX (chapter 8.3) a zero-length prefix means current
 1702        -- working directory. Replace empty strings in the env variable with
 1703        -- `working_dir` (see also #14695).
 1704        working_dir <- getCurrentDirectory
 1705        values <- lookupEnv name
 1706        case values of
 1707          Nothing  -> return list
 1708          Just arr -> return $ list ++ splitEnv working_dir arr
 1709     where
 1710       splitEnv :: FilePath -> String -> [String]
 1711       splitEnv working_dir value =
 1712         case break (== envListSep) value of
 1713           (x, []    ) ->
 1714             [if null x then working_dir else x]
 1715           (x, (_:xs)) ->
 1716             (if null x then working_dir else x) : splitEnv working_dir xs
 1717 #if defined(mingw32_HOST_OS)
 1718       envListSep = ';'
 1719 #else
 1720       envListSep = ':'
 1721 #endif
 1722 
 1723 -- ----------------------------------------------------------------------------
 1724 -- Loading a dynamic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
 1725 
 1726 
 1727 {- **********************************************************************
 1728 
 1729                 Helper functions
 1730 
 1731   ********************************************************************* -}
 1732 
 1733 maybePutSDoc :: Logger -> SDoc -> IO ()
 1734 maybePutSDoc logger s
 1735     = when (logVerbAtLeast logger 2) $
 1736           logMsg logger
 1737               MCInteractive
 1738               noSrcSpan
 1739               $ withPprStyle defaultUserStyle s
 1740 
 1741 maybePutStr :: Logger -> String -> IO ()
 1742 maybePutStr logger s = maybePutSDoc logger (text s)
 1743 
 1744 maybePutStrLn :: Logger -> String -> IO ()
 1745 maybePutStrLn logger s = maybePutSDoc logger (text s <> text "\n")