Linker.hs 56.7 KB
Newer Older
1
{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections, RecordWildCards #-}
2
{-# OPTIONS_GHC -fno-cse #-}
Moritz Angermann's avatar
Moritz Angermann committed
3 4
-- -fno-cse is needed for GLOBAL_VAR's to behave properly

5 6 7
--
--  (c) The University of Glasgow 2002-2006
--
8 9 10 11 12
-- | The dynamic linker for GHCi.
--
-- This module deals with the top-level issues of dynamic linking,
-- calling the object-code linker and the byte-code linker where
-- necessary.
13
module Linker ( getHValue, showLinkerState,
14
                linkExpr, linkDecls, unload, withExtendedLinkEnv,
15
                extendLinkEnv, deleteFromLinkEnv,
16 17
                extendLoadedPkgs,
                linkPackages,initDynLinker,linkModule,
Moritz Angermann's avatar
Moritz Angermann committed
18
                linkCmdLineLibs
19
        ) where
sof's avatar
sof committed
20

21
#include "HsVersions.h"
22

23 24
import GHCi
import GHCi.RemoteTypes
25
import LoadIface
26 27
import ByteCodeLink
import ByteCodeAsm
28
import ByteCodeTypes
29
import TcRnMonad
30
import Packages
31 32
import DriverPhases
import Finder
33
import HscTypes
34
import Name
35
import NameEnv
36
import Module
37 38 39
import ListSetOps
import DynFlags
import BasicTypes
40
import Outputable
41 42 43 44
import Panic
import Util
import ErrUtils
import SrcLoc
45
import qualified Maybes
46
import UniqDSet
47
import FastString
48
import Platform
49
import SysTools
50

51
-- Standard libraries
52
import Control.Monad
53
import Control.Applicative((<|>))
54

55 56
import Data.IORef
import Data.List
57
import Data.Maybe
58
import Control.Concurrent.MVar
59

Ian Lynagh's avatar
Ian Lynagh committed
60
import System.FilePath
61
import System.Directory
62

63
import Exception
64

Moritz Angermann's avatar
Moritz Angermann committed
65 66 67 68 69
#if __GLASGOW_HASKELL__ >= 709
import Foreign
#else
import Foreign.Safe
#endif
70

71 72
{- **********************************************************************

73
                        The Linker's state
74

75 76 77
  ********************************************************************* -}

{-
78
The persistent linker state *must* match the actual state of the
79 80
C dynamic linker at all times, so we keep it in a private global variable.

81 82 83
The global IORef used for PersistentLinkerState actually contains another MVar.
The reason for this is that we want to allow another loaded copy of the GHC
library to side-effect the PLS and for those changes to be reflected here.
84 85 86

The PersistentLinkerState maps Names to actual closures (for
interpreted code only), for use during linking.
87
-}
Moritz Angermann's avatar
Moritz Angermann committed
88
#if STAGE < 2
89
GLOBAL_VAR_M(v_PersistentLinkerState, newMVar (panic "Dynamic linker not initialised"), MVar PersistentLinkerState)
90
GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised
Moritz Angermann's avatar
Moritz Angermann committed
91 92 93 94 95 96 97 98 99 100 101 102 103
#else
SHARED_GLOBAL_VAR_M( v_PersistentLinkerState
                   , getOrSetLibHSghcPersistentLinkerState
                   , "getOrSetLibHSghcPersistentLinkerState"
                   , newMVar (panic "Dynamic linker not initialised")
                   , MVar PersistentLinkerState)
-- Set True when dynamic linker is initialised
SHARED_GLOBAL_VAR( v_InitLinkerDone
                 , getOrSetLibHSghcInitLinkerDone
                 , "getOrSetLibHSghcInitLinkerDone"
                 , False
                 , Bool)
#endif
104

105 106 107 108 109 110
modifyPLS_ :: (PersistentLinkerState -> IO PersistentLinkerState) -> IO ()
modifyPLS_ f = readIORef v_PersistentLinkerState >>= flip modifyMVar_ f

modifyPLS :: (PersistentLinkerState -> IO (PersistentLinkerState, a)) -> IO a
modifyPLS f = readIORef v_PersistentLinkerState >>= flip modifyMVar f

111 112 113
data PersistentLinkerState
   = PersistentLinkerState {

114
        -- Current global mapping from Names to their true values
115 116
        closure_env :: ClosureEnv,

117 118 119 120 121
        -- The current global mapping from RdrNames of DataCons to
        -- info table addresses.
        -- When a new Unlinked is linked into the running image, or an existing
        -- module in the image is replaced, the itbl_env must be updated
        -- appropriately.
122
        itbl_env    :: !ItblEnv,
123

124 125
        -- The currently loaded interpreted modules (home package)
        bcos_loaded :: ![Linkable],
126

127 128
        -- And the currently-loaded compiled modules (home package)
        objs_loaded :: ![Linkable],
129

130 131 132
        -- The currently-loaded packages; always object code
        -- Held, as usual, in dependency order; though I am not sure if
        -- that is really important
133
        pkgs_loaded :: ![LinkerUnitId],
134

135 136 137
        -- we need to remember the name of previous temporary DLL/.so
        -- libraries so we can link them (see #10322)
        temp_sos :: ![(FilePath, String)] }
138

139

140
emptyPLS :: DynFlags -> PersistentLinkerState
141 142 143 144 145
emptyPLS _ = PersistentLinkerState {
                        closure_env = emptyNameEnv,
                        itbl_env    = emptyNameEnv,
                        pkgs_loaded = init_pkgs,
                        bcos_loaded = [],
146
                        objs_loaded = [],
147
                        temp_sos = [] }
148 149

  -- Packages that don't need loading, because the compiler
150 151 152 153
  -- shares them with the interpreted program.
  --
  -- The linker's symbol table is populated with RTS symbols using an
  -- explicit list.  See rts/Linker.c for details.
154
  where init_pkgs = map toInstalledUnitId [rtsUnitId]
155

156

157
extendLoadedPkgs :: [InstalledUnitId] -> IO ()
158
extendLoadedPkgs pkgs =
159
  modifyPLS_ $ \s ->
160
      return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }
161

162
extendLinkEnv :: [(Name,ForeignHValue)] -> IO ()
163
extendLinkEnv new_bindings =
164 165 166 167
  modifyPLS_ $ \pls -> do
    let ce = closure_env pls
    let new_ce = extendClosureEnv ce new_bindings
    return pls{ closure_env = new_ce }
168

169
deleteFromLinkEnv :: [Name] -> IO ()
170
deleteFromLinkEnv to_remove =
171 172 173 174
  modifyPLS_ $ \pls -> do
    let ce = closure_env pls
    let new_ce = delListFromNameEnv ce to_remove
    return pls{ closure_env = new_ce }
175

176 177 178 179 180
-- | Get the 'HValue' associated with the given name.
--
-- May cause loading the module that contains the name.
--
-- Throws a 'ProgramError' if loading fails or the name cannot be found.
181
getHValue :: HscEnv -> Name -> IO ForeignHValue
182
getHValue hsc_env name = do
183
  initDynLinker hsc_env
184
  pls <- modifyPLS $ \pls -> do
185
           if (isExternalName name) then do
186 187
             (pls', ok) <- linkDependencies hsc_env pls noSrcSpan
                              [nameModule name]
188
             if (failed ok) then throwGhcExceptionIO (ProgramError "")
189 190 191
                            else return (pls', pls')
            else
             return (pls, pls)
192 193 194 195 196 197 198 199 200 201
  case lookupNameEnv (closure_env pls) name of
    Just (_,aa) -> return aa
    Nothing
        -> ASSERT2(isExternalName name, ppr name)
           do let sym_to_find = nameToCLabel name "closure"
              m <- lookupClosure hsc_env (unpackFS sym_to_find)
              case m of
                Just hvref -> mkFinalizedHValue hsc_env hvref
                Nothing -> linkFail "ByteCodeLink.lookupCE"
                             (unpackFS sym_to_find)
202

203 204 205 206
linkDependencies :: HscEnv -> PersistentLinkerState
                 -> SrcSpan -> [Module]
                 -> IO (PersistentLinkerState, SuccessFlag)
linkDependencies hsc_env pls span needed_mods = do
207
--   initDynLinker (hsc_dflags hsc_env)
208 209
   let hpt = hsc_HPT hsc_env
       dflags = hsc_dflags hsc_env
210 211 212 213
   -- 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.
214 215
   maybe_normal_osuf <- checkNonStdWay dflags span

216
   -- Find what packages and linkables are required
217
   (lnks, pkgs) <- getLinkDeps hsc_env hpt pls
218
                               maybe_normal_osuf span needed_mods
219

220
   -- Link the packages and modules required
221 222
   pls1 <- linkPackages' hsc_env pkgs pls
   linkModules hsc_env pls1 lnks
223

224

225 226
-- | Temporarily extend the linker state.

227
withExtendedLinkEnv :: (ExceptionMonad m) =>
228
                       [(Name,ForeignHValue)] -> m a -> m a
229
withExtendedLinkEnv new_env action
230
    = gbracket (liftIO $ extendLinkEnv new_env)
231 232
               (\_ -> reset_old_env)
               (\_ -> action)
233
    where
234 235 236 237 238
        -- Remember that the linker state might be side-effected
        -- during the execution of the IO action, and we don't want to
        -- lose those changes (we might have linked a new module or
        -- package), so the reset action only removes the names we
        -- added earlier.
239
          reset_old_env = liftIO $ do
240
            modifyPLS_ $ \pls ->
241 242
                let cur = closure_env pls
                    new = delListFromNameEnv cur (map fst new_env)
243
                in return pls{ closure_env = new }
244

245

246
-- | Display the persistent linker state.
247 248
showLinkerState :: DynFlags -> IO ()
showLinkerState dflags
249
  = do pls <- readIORef v_PersistentLinkerState >>= readMVar
250
       log_action dflags dflags NoReason SevDump noSrcSpan defaultDumpStyle
251
                 (vcat [text "----- Linker state -----",
252 253 254
                        text "Pkgs:" <+> ppr (pkgs_loaded pls),
                        text "Objs:" <+> ppr (objs_loaded pls),
                        text "BCOs:" <+> ppr (bcos_loaded pls)])
255

256

257 258 259 260 261
{- **********************************************************************

                        Initialisation

  ********************************************************************* -}
262

263 264 265 266 267 268 269 270 271 272
-- | Initialise the dynamic linker.  This entails
--
--  a) Calling the C initialisation procedure,
--
--  b) Loading any packages specified on the command line,
--
--  c) Loading any packages specified on the command line, now held in the
--     @-l@ options in @v_Opt_l@,
--
--  d) Loading any @.o\/.dll@ files specified on the command line, now held
273
--     in @ldInputs@,
274 275 276 277 278 279 280
--
--  e) Loading any MacOS frameworks.
--
-- NOTE: This function is idempotent; if called more than once, it does
-- nothing.  This is useful in Template Haskell, where we call it before
-- trying to link.
--
281 282
initDynLinker :: HscEnv -> IO ()
initDynLinker hsc_env =
283
  modifyPLS_ $ \pls0 -> do
284 285 286
    done <- readIORef v_InitLinkerDone
    if done then return pls0
            else do writeIORef v_InitLinkerDone True
287
                    reallyInitDynLinker hsc_env
288

289 290 291 292 293
reallyInitDynLinker :: HscEnv -> IO PersistentLinkerState
reallyInitDynLinker hsc_env = do
  -- Initialise the linker state
  let dflags = hsc_dflags hsc_env
      pls0 = emptyPLS dflags
294

295 296
  -- (a) initialise the C dynamic linker
  initObjLinker hsc_env
297

298 299
  -- (b) Load packages from the command-line (Note [preload packages])
  pls <- linkPackages' hsc_env (preloadPackages (pkgState dflags)) pls0
300

301 302
  -- steps (c), (d) and (e)
  linkCmdLineLibs' hsc_env pls
303

304 305 306 307

linkCmdLineLibs :: HscEnv -> IO ()
linkCmdLineLibs hsc_env = do
  initDynLinker hsc_env
308
  modifyPLS_ $ \pls -> do
309 310 311 312 313 314 315
    linkCmdLineLibs' hsc_env pls

linkCmdLineLibs' :: HscEnv -> PersistentLinkerState -> IO PersistentLinkerState
linkCmdLineLibs' hsc_env pls =
  do
      let dflags@(DynFlags { ldInputs = cmdline_ld_inputs
                           , libraryPaths = lib_paths}) = hsc_dflags hsc_env
316

317
      -- (c) Link libraries from the command-line
318
      let minus_ls = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ]
319
      libspecs <- mapM (locateLib hsc_env False lib_paths) minus_ls
320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343

      -- (d) Link .o files from the command-line
      classified_ld_inputs <- mapM (classifyLdInput dflags)
                                [ f | FileOption _ f <- cmdline_ld_inputs ]

      -- (e) Link any MacOS frameworks
      let platform = targetPlatform dflags
      let (framework_paths, frameworks) =
            if platformUsesFrameworks platform
             then (frameworkPaths dflags, cmdlineFrameworks dflags)
              else ([],[])

      -- Finally do (c),(d),(e)
      let cmdline_lib_specs = catMaybes classified_ld_inputs
                           ++ libspecs
                           ++ map Framework frameworks
      if null cmdline_lib_specs then return pls
                                else do

      -- Add directories to library search paths
      let all_paths = let paths = framework_paths
                               ++ lib_paths
                               ++ [ takeDirectory dll | DLLPath dll <- libspecs ]
                      in nub $ map normalise paths
344
      pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths
345

346
      pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls
347 348
                    cmdline_lib_specs
      maybePutStr dflags "final link ... "
349
      ok <- resolveObjs hsc_env
350 351

      -- DLLs are loaded, reset the search paths
352
      mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache
353 354 355 356 357

      if succeeded ok then maybePutStrLn dflags "done"
      else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed")

      return pls1
358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383

{- Note [preload packages]

Why do we need to preload packages from the command line?  This is an
explanation copied from #2437:

I tried to implement the suggestion from #3560, thinking it would be
easy, but there are two reasons we link in packages eagerly when they
are mentioned on the command line:

  * So that you can link in extra object files or libraries that
    depend on the packages. e.g. ghc -package foo -lbar where bar is a
    C library that depends on something in foo. So we could link in
    foo eagerly if and only if there are extra C libs or objects to
    link in, but....

  * Haskell code can depend on a C function exported by a package, and
    the normal dependency tracking that TH uses can't know about these
    dependencies. The test ghcilink004 relies on this, for example.

I conclude that we need two -package flags: one that says "this is a
package I want to make available", and one that says "this is a
package I want to link in eagerly". Would that be too complicated for
users?
-}

384 385
classifyLdInput :: DynFlags -> FilePath -> IO (Maybe LibrarySpec)
classifyLdInput dflags f
386 387
  | isObjectFilename platform f = return (Just (Object f))
  | isDynLibFilename platform f = return (Just (DLLPath f))
388
  | otherwise          = do
389
        log_action dflags dflags NoReason SevInfo noSrcSpan defaultUserStyle
390
            (text ("Warning: ignoring unrecognised input `" ++ f ++ "'"))
391
        return Nothing
392
    where platform = targetPlatform dflags
393

394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441
preloadLib
  :: HscEnv -> [String] -> [String] -> PersistentLinkerState
  -> LibrarySpec -> IO PersistentLinkerState
preloadLib hsc_env lib_paths framework_paths pls lib_spec = do
  maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
  case lib_spec of
    Object static_ish -> do
      (b, pls1) <- preload_static lib_paths static_ish
      maybePutStrLn dflags (if b  then "done" else "not found")
      return pls1

    Archive static_ish -> do
      b <- preload_static_archive lib_paths static_ish
      maybePutStrLn dflags (if b  then "done" else "not found")
      return pls

    DLL dll_unadorned -> do
      maybe_errstr <- loadDLL hsc_env (mkSOName platform dll_unadorned)
      case maybe_errstr of
         Nothing -> maybePutStrLn dflags "done"
         Just mm | platformOS platform /= OSDarwin ->
           preloadFailed mm lib_paths lib_spec
         Just mm | otherwise -> do
           -- As a backup, on Darwin, try to also load a .so file
           -- since (apparently) some things install that way - see
           -- ticket #8770.
           let libfile = ("lib" ++ dll_unadorned) <.> "so"
           err2 <- loadDLL hsc_env libfile
           case err2 of
             Nothing -> maybePutStrLn dflags "done"
             Just _  -> preloadFailed mm lib_paths lib_spec
      return pls

    DLLPath dll_path -> do
      do maybe_errstr <- loadDLL hsc_env dll_path
         case maybe_errstr of
            Nothing -> maybePutStrLn dflags "done"
            Just mm -> preloadFailed mm lib_paths lib_spec
         return pls

    Framework framework ->
      if platformUsesFrameworks (targetPlatform dflags)
      then do maybe_errstr <- loadFramework hsc_env framework_paths framework
              case maybe_errstr of
                 Nothing -> maybePutStrLn dflags "done"
                 Just mm -> preloadFailed mm framework_paths lib_spec
              return pls
      else panic "preloadLib Framework"
Ian Lynagh's avatar
Ian Lynagh committed
442

443
  where
444 445
    dflags = hsc_dflags hsc_env

446 447
    platform = targetPlatform dflags

448 449
    preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
    preloadFailed sys_errmsg paths spec
450
       = do maybePutStr dflags "failed.\n"
451
            throwGhcExceptionIO $
452
              CmdLineError (
453 454 455 456
                    "user specified .o/.so/.DLL could not be loaded ("
                    ++ sys_errmsg ++ ")\nWhilst trying to load:  "
                    ++ showLS spec ++ "\nAdditional directories searched:"
                    ++ (if null paths then " (none)" else
457
                        intercalate "\n" (map ("   "++) paths)))
458

459
    -- Not interested in the paths in the static case.
Ian Lynagh's avatar
Ian Lynagh committed
460
    preload_static _paths name
461
       = do b <- doesFileExist name
462 463
            if not b then return (False, pls)
                     else if dynamicGhc
464
                             then  do pls1 <- dynLoadObjs hsc_env pls [name]
465
                                      return (True, pls1)
466
                             else  do loadObj hsc_env name
467 468
                                      return (True, pls)

469 470 471
    preload_static_archive _paths name
       = do b <- doesFileExist name
            if not b then return False
472
                     else do if dynamicGhc
473
                                 then panic "Loading archives not supported"
474
                                 else loadArchive hsc_env name
475
                             return True
476 477


478 479 480 481 482
{- **********************************************************************

                        Link a byte-code expression

  ********************************************************************* -}
483

484
-- | Link a single expression, /including/ first linking packages and
485 486
-- modules that this expression depends on.
--
487 488
-- Raises an IO exception ('ProgramError') if it can't find a compiled
-- version of the dependents to link.
489
--
490
linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue
491
linkExpr hsc_env span root_ul_bco
492 493
  = do {
     -- Initialise the linker (if it's not been done already)
494
   ; initDynLinker hsc_env
495

496
     -- Take lock for the actual work.
497
   ; modifyPLS $ \pls0 -> do {
498

499
     -- Link the packages and modules required
500
   ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods
501
   ; if failed ok then
502
        throwGhcExceptionIO (ProgramError "")
503 504
     else do {

505
     -- Link the expression itself
506
     let ie = itbl_env pls
507
         ce = closure_env pls
508

509
     -- Link the necessary packages and linkables
510

511 512 513
   ; let nobreakarray = error "no break array"
         bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)]
   ; resolved <- linkBCO hsc_env ie ce bco_ix nobreakarray root_ul_bco
514
   ; [root_hvref] <- createBCOs hsc_env [resolved]
515 516
   ; fhv <- mkFinalizedHValue hsc_env root_hvref
   ; return (pls, fhv)
517
   }}}
518
   where
519
     free_names = uniqDSetToList (bcoFreeNames root_ul_bco)
520

521
     needed_mods :: [Module]
522
     needed_mods = [ nameModule n | n <- free_names,
523 524 525
                     isExternalName n,      -- Names from other modules
                     not (isWiredInName n)  -- Exclude wired-in names
                   ]                        -- (see note below)
526 527 528 529 530
        -- Exclude wired-in names because we may not have read
        -- their interface files, so getLinkDeps will fail
        -- All wired-in names are in the base package, which we link
        -- by default, so we can safely ignore them here.

Ian Lynagh's avatar
Ian Lynagh committed
531
dieWith :: DynFlags -> SrcSpan -> MsgDoc -> IO a
532
dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg)))
533 534


535
checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
536
checkNonStdWay dflags srcspan
537 538 539 540 541
  | gopt Opt_ExternalInterpreter dflags = return 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.

542 543 544 545 546 547 548 549 550 551 552 553 554
  | interpWays == haskellWays = return Nothing
    -- Only if we are compiling with the same ways as GHC is built
    -- with, can we dynamically load those object files. (see #3604)

  | objectSuf dflags == normalObjectSuffix && not (null haskellWays)
  = failNonStd dflags srcspan

  | otherwise = return (Just (interpTag ++ "o"))
  where
    haskellWays = filter (not . wayRTSOnly) (ways dflags)
    interpTag = case mkBuildTag interpWays of
                  "" -> ""
                  tag -> tag ++ "_"
555

556 557 558
normalObjectSuffix :: String
normalObjectSuffix = phaseInputExt StopLn

559
failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
Ian Lynagh's avatar
Ian Lynagh committed
560
failNonStd dflags srcspan = dieWith dflags srcspan $
561 562 563 564 565 566 567 568
  text "Cannot load" <+> compWay <+>
     text "objects when GHC is built" <+> ghciWay $$
  text "To fix this, either:" $$
  text "  (1) Use -fexternal-interprter, or" $$
  text "  (2) Build the program twice: once" <+>
                       ghciWay <> text ", and then" $$
  text "      with" <+> compWay <+>
     text "using -osuf to set a different object file suffix."
569
    where compWay
570 571 572
            | WayDyn `elem` ways dflags = text "-dynamic"
            | WayProf `elem` ways dflags = text "-prof"
            | otherwise = text "normal"
573
          ghciWay
574 575 576
            | dynamicGhc = text "with -dynamic"
            | rtsIsProfiled = text "with -prof"
            | otherwise = text "the normal way"
577

578 579
getLinkDeps :: HscEnv -> HomePackageTable
            -> PersistentLinkerState
580
            -> Maybe FilePath                   -- replace object suffices?
581 582
            -> SrcSpan                          -- for error messages
            -> [Module]                         -- If you need these
583
            -> IO ([Linkable], [InstalledUnitId])     -- ... then link these first
584
-- Fails with an IO exception if it can't find enough files
585

586
getLinkDeps hsc_env hpt pls replace_osuf span mods
587
-- Find all the packages and linkables that a set of modules depends on
588
 = do {
589
        -- 1.  Find the dependent home-pkg-modules/packages from each iface
590 591
        -- (omitting modules from the interactive package, which is already linked)
      ; (mods_s, pkgs_s) <- follow_deps (filterOut isInteractiveModule mods)
niteria's avatar
niteria committed
592
                                        emptyUniqDSet emptyUniqDSet;
593

594
      ; let {
595 596 597 598
        -- 2.  Exclude ones already linked
        --      Main reason: avoid findModule calls in get_linkable
            mods_needed = mods_s `minusList` linked_mods     ;
            pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ;
599

600
            linked_mods = map (moduleName.linkableModule)
601
                                (objs_loaded pls ++ bcos_loaded pls)  }
602 603 604

        -- 3.  For each dependent module, find its linkable
        --     This will either be in the HPT or (in the case of one-shot
605
        --     compilation) we may need to use maybe_getFileLinkable
606
      ; let { osuf = objectSuf dflags }
607
      ; lnks_needed <- mapM (get_linkable osuf) mods_needed
608

609
      ; return (lnks_needed, pkgs_needed) }
610
  where
Simon Marlow's avatar
Simon Marlow committed
611 612 613
    dflags = hsc_dflags hsc_env
    this_pkg = thisPackage dflags

614 615 616 617 618 619
        -- 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
niteria's avatar
niteria committed
620
                -> UniqDSet ModuleName         -- accum. module dependencies
621 622
                -> UniqDSet InstalledUnitId          -- accum. package dependencies
                -> IO ([ModuleName], [InstalledUnitId]) -- result
Simon Marlow's avatar
Simon Marlow committed
623
    follow_deps []     acc_mods acc_pkgs
niteria's avatar
niteria committed
624
        = return (uniqDSetToList acc_mods, uniqDSetToList acc_pkgs)
Simon Marlow's avatar
Simon Marlow committed
625
    follow_deps (mod:mods) acc_mods acc_pkgs
626
        = do
627
          mb_iface <- initIfaceCheck (text "getLinkDeps") hsc_env $
628 629
                        loadInterface msg mod (ImportByUser False)
          iface <- case mb_iface of
630
                    Maybes.Failed err      -> throwGhcExceptionIO (ProgramError (showSDoc dflags err))
631
                    Maybes.Succeeded iface -> return iface
632 633 634 635

          when (mi_boot iface) $ link_boot_mod_error mod

          let
636
            pkg = moduleUnitId mod
637 638 639 640 641 642 643
            deps  = mi_deps iface

            pkg_deps = dep_pkgs deps
            (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps)
                    where is_boot (m,True)  = Left m
                          is_boot (m,False) = Right m

niteria's avatar
niteria committed
644 645 646
            boot_deps' = filter (not . (`elementOfUniqDSet` acc_mods)) boot_deps
            acc_mods'  = addListToUniqDSet acc_mods (moduleName mod : mod_deps)
            acc_pkgs'  = addListToUniqDSet acc_pkgs $ map fst pkg_deps
647 648
          --
          if pkg /= this_pkg
649
             then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toInstalledUnitId pkg))
650 651 652 653 654
             else follow_deps (map (mkModule this_pkg) boot_deps' ++ mods)
                              acc_mods' acc_pkgs'
        where
            msg = text "need to link module" <+> ppr mod <+>
                  text "due to use of Template Haskell"
Simon Marlow's avatar
Simon Marlow committed
655 656


657
    link_boot_mod_error mod =
658
        throwGhcExceptionIO (ProgramError (showSDoc dflags (
659
            text "module" <+> ppr mod <+>
Simon Marlow's avatar
Simon Marlow committed
660
            text "cannot be linked; it is only available as a boot module")))
661

662
    no_obj :: Outputable a => a -> IO b
Ian Lynagh's avatar
Ian Lynagh committed
663
    no_obj mod = dieWith dflags span $
664
                     text "cannot find object file for module " <>
665 666 667
                        quotes (ppr mod) $$
                     while_linking_expr

668
    while_linking_expr = text "while linking an interpreted expression"
669

670
        -- This one is a build-system bug
671

672
    get_linkable osuf mod_name      -- A home-package module
niteria's avatar
niteria committed
673
        | Just mod_info <- lookupHpt hpt mod_name
674
        = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))
675 676 677 678 679
        | otherwise
        = do    -- It's not in the HPT because we are in one shot mode,
                -- so use the Finder to get a ModLocation...
             mb_stuff <- findHomeModule hsc_env mod_name
             case mb_stuff of
680
                  Found loc mod -> found loc mod
681
                  _ -> no_obj mod_name
682 683
        where
            found loc mod = do {
684 685 686 687
                -- ...and then find the linkable for it
               mb_lnk <- findObjectLinkableMaybe mod loc ;
               case mb_lnk of {
                  Nothing  -> no_obj mod ;
688
                  Just lnk -> adjust_linkable lnk
689
              }}
690

691
            adjust_linkable lnk
692 693 694
                | Just new_osuf <- replace_osuf = do
                        new_uls <- mapM (adjust_ul new_osuf)
                                        (linkableUnlinked lnk)
695
                        return lnk{ linkableUnlinked=new_uls }
696
                | otherwise =
697
                        return lnk
698

699
            adjust_ul new_osuf (DotO file) = do
700
                MASSERT(osuf `isSuffixOf` file)
701
                let file_base = fromJust (stripExtension osuf file)
702 703 704 705
                    new_file = file_base <.> new_osuf
                ok <- doesFileExist new_file
                if (not ok)
                   then dieWith dflags span $
706
                          text "cannot find object file "
707 708 709 710 711
                                <> quotes (text new_file) $$ while_linking_expr
                   else return (DotO new_file)
            adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp)
            adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp)
            adjust_ul _ l@(BCOs {}) = return l
712

713

714 715
{- **********************************************************************

716
              Loading a Decls statement
717 718 719

  ********************************************************************* -}

720
linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO ()
721
linkDecls hsc_env span cbc@CompiledByteCode{..} = do
722
    -- Initialise the linker (if it's not been done already)
723
    initDynLinker hsc_env
724 725 726 727 728 729 730

    -- Take lock for the actual work.
    modifyPLS $ \pls0 -> do

    -- Link the packages and modules required
    (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods
    if failed ok
731
      then throwGhcExceptionIO (ProgramError "")
732 733 734
      else do

    -- Link the expression itself
735
    let ie = plusNameEnv (itbl_env pls) bc_itbls
736 737 738
        ce = closure_env pls

    -- Link the necessary packages and linkables
739
    new_bindings <- linkSomeBCOs hsc_env ie ce [cbc]
740 741 742 743
    nms_fhvs <- makeForeignNamedHValueRefs hsc_env new_bindings
    let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs
                   , itbl_env    = ie }
    return (pls2, ())
744
  where
745 746
    free_names = uniqDSetToList $
      foldr (unionUniqDSets . bcoFreeNames) emptyUniqDSet bc_bcos
747 748

    needed_mods :: [Module]
749
    needed_mods = [ nameModule n | n <- free_names,
750 751 752 753 754 755 756 757
                    isExternalName n,       -- Names from other modules
                    not (isWiredInName n)   -- Exclude wired-in names
                  ]                         -- (see note below)
    -- Exclude wired-in names because we may not have read
    -- their interface files, so getLinkDeps will fail
    -- All wired-in names are in the base package, which we link
    -- by default, so we can safely ignore them here.

758 759
{- **********************************************************************

760 761
              Loading a single module

762 763
  ********************************************************************* -}

764 765
linkModule :: HscEnv -> Module -> IO ()
linkModule hsc_env mod = do
766
  initDynLinker hsc_env
767
  modifyPLS_ $ \pls -> do
768
    (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod]
769
    if (failed ok) then throwGhcExceptionIO (ProgramError "could not link module")
770
      else return pls'
771

772 773
{- **********************************************************************

774 775 776
                Link some linkables
        The linkables may consist of a mixture of
        byte-code modules and object modules
777

778 779
  ********************************************************************* -}

780
linkModules :: HscEnv -> PersistentLinkerState -> [Linkable]
781
            -> IO (PersistentLinkerState, SuccessFlag)
782
linkModules hsc_env pls linkables
783
  = mask_ $ do  -- don't want to be interrupted by ^C in here
784 785

        let (objs, bcos) = partition isObjectLinkable
786 787
                              (concatMap partitionLinkable linkables)

788
                -- Load objects first; they can't depend on BCOs
789
        (pls1, ok_flag) <- dynLinkObjs hsc_env pls objs
790 791 792 793

        if failed ok_flag then
                return (pls1, Failed)
          else do
794
                pls2 <- dynLinkBCOs hsc_env pls1 bcos
795
                return (pls2, Succeeded)
796 797 798 799 800 801 802 803


-- HACK to support f-x-dynamic in the interpreter; no other purpose
partitionLinkable :: Linkable -> [Linkable]
partitionLinkable li
   = let li_uls = linkableUnlinked li
         li_uls_obj = filter isObject li_uls
         li_uls_bco = filter isInterpretable li_uls
804
     in
805
         case (li_uls_obj, li_uls_bco) of
Ian Lynagh's avatar
Ian Lynagh committed
806 807 808
            (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj},
                           li {linkableUnlinked=li_uls_bco}]
            _ -> [li]
809

810
findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
811 812 813 814
findModuleLinkable_maybe lis mod
   = case [LM time nm us | LM time nm us <- lis, nm == mod] of
        []   -> Nothing
        [li] -> Just li
Ian Lynagh's avatar
Ian Lynagh committed
815
        _    -> pprPanic "findModuleLinkable" (ppr mod)
816 817 818

linkableInSet :: Linkable -> [Linkable] -> Bool
linkableInSet l objs_loaded =
819
  case findModuleLinkable_maybe objs_loaded (linkableModule l) of
820 821
        Nothing -> False
        Just m  -> linkableTime l == linkableTime m
822 823


824 825 826 827 828
{- **********************************************************************

                The object-code linker

  ********************************************************************* -}
829

830
dynLinkObjs :: HscEnv -> PersistentLinkerState -> [Linkable]
831
            -> IO (PersistentLinkerState, SuccessFlag)
832
dynLinkObjs hsc_env pls objs = do
833 834 835 836
        -- Load the object files and link them
        let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
            pls1                     = pls { objs_loaded = objs_loaded' }
            unlinkeds                = concatMap linkableUnlinked new_objs
837 838
            wanted_objs              = map nameOfObject unlinkeds

839
        if interpreterDynamic (hsc_dflags hsc_env)
840
            then do pls2 <- dynLoadObjs hsc_env pls1 wanted_objs
841
                    return (pls2, Succeeded)
842
            else do mapM_ (loadObj</