Linker.hs 57.4 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

65
import Foreign (Ptr) -- needed for 2nd stage
66

67 68
{- **********************************************************************

69
                        The Linker's state
70

71 72 73
  ********************************************************************* -}

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

77 78 79
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.
80 81 82

The PersistentLinkerState maps Names to actual closures (for
interpreted code only), for use during linking.
83
-}
Moritz Angermann's avatar
Moritz Angermann committed
84
#if STAGE < 2
85
GLOBAL_VAR_M(v_PersistentLinkerState, newMVar (panic "Dynamic linker not initialised"), MVar PersistentLinkerState)
86
GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised
Moritz Angermann's avatar
Moritz Angermann committed
87 88 89 90 91 92 93 94 95 96 97 98 99
#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
100

101 102 103 104 105 106
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

107 108 109
data PersistentLinkerState
   = PersistentLinkerState {

110
        -- Current global mapping from Names to their true values
111 112
        closure_env :: ClosureEnv,

113 114 115 116 117
        -- 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.
118
        itbl_env    :: !ItblEnv,
119

120 121
        -- The currently loaded interpreted modules (home package)
        bcos_loaded :: ![Linkable],
122

123 124
        -- And the currently-loaded compiled modules (home package)
        objs_loaded :: ![Linkable],
125

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

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

135

136
emptyPLS :: DynFlags -> PersistentLinkerState
137 138 139 140 141
emptyPLS _ = PersistentLinkerState {
                        closure_env = emptyNameEnv,
                        itbl_env    = emptyNameEnv,
                        pkgs_loaded = init_pkgs,
                        bcos_loaded = [],
142
                        objs_loaded = [],
143
                        temp_sos = [] }
144 145

  -- Packages that don't need loading, because the compiler
146 147 148 149
  -- 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.
150
  where init_pkgs = map toInstalledUnitId [rtsUnitId]
151

152

153
extendLoadedPkgs :: [InstalledUnitId] -> IO ()
154
extendLoadedPkgs pkgs =
155
  modifyPLS_ $ \s ->
156
      return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }
157

158
extendLinkEnv :: [(Name,ForeignHValue)] -> IO ()
159
extendLinkEnv new_bindings =
160 161 162 163
  modifyPLS_ $ \pls -> do
    let ce = closure_env pls
    let new_ce = extendClosureEnv ce new_bindings
    return pls{ closure_env = new_ce }
164

165
deleteFromLinkEnv :: [Name] -> IO ()
166
deleteFromLinkEnv to_remove =
167 168 169 170
  modifyPLS_ $ \pls -> do
    let ce = closure_env pls
    let new_ce = delListFromNameEnv ce to_remove
    return pls{ closure_env = new_ce }
171

172 173 174 175 176
-- | 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.
177
getHValue :: HscEnv -> Name -> IO ForeignHValue
178
getHValue hsc_env name = do
179
  initDynLinker hsc_env
180
  pls <- modifyPLS $ \pls -> do
181
           if (isExternalName name) then do
182 183
             (pls', ok) <- linkDependencies hsc_env pls noSrcSpan
                              [nameModule name]
184
             if (failed ok) then throwGhcExceptionIO (ProgramError "")
185 186 187
                            else return (pls', pls')
            else
             return (pls, pls)
188 189 190 191 192 193 194 195 196 197
  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)
198

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

212
   -- Find what packages and linkables are required
213
   (lnks, pkgs) <- getLinkDeps hsc_env hpt pls
214
                               maybe_normal_osuf span needed_mods
215

216
   -- Link the packages and modules required
217 218
   pls1 <- linkPackages' hsc_env pkgs pls
   linkModules hsc_env pls1 lnks
219

220

221 222
-- | Temporarily extend the linker state.

223
withExtendedLinkEnv :: (ExceptionMonad m) =>
224
                       [(Name,ForeignHValue)] -> m a -> m a
225
withExtendedLinkEnv new_env action
226
    = gbracket (liftIO $ extendLinkEnv new_env)
227 228
               (\_ -> reset_old_env)
               (\_ -> action)
229
    where
230 231 232 233 234
        -- 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.
235
          reset_old_env = liftIO $ do
236
            modifyPLS_ $ \pls ->
237 238
                let cur = closure_env pls
                    new = delListFromNameEnv cur (map fst new_env)
239
                in return pls{ closure_env = new }
240

241

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

252

253 254 255 256 257
{- **********************************************************************

                        Initialisation

  ********************************************************************* -}
258

259 260 261 262 263 264 265 266 267 268
-- | 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
269
--     in @ldInputs@,
270 271 272 273 274 275 276
--
--  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.
--
277 278
initDynLinker :: HscEnv -> IO ()
initDynLinker hsc_env =
279
  modifyPLS_ $ \pls0 -> do
280 281 282
    done <- readIORef v_InitLinkerDone
    if done then return pls0
            else do writeIORef v_InitLinkerDone True
283
                    reallyInitDynLinker hsc_env
284

285 286 287 288 289
reallyInitDynLinker :: HscEnv -> IO PersistentLinkerState
reallyInitDynLinker hsc_env = do
  -- Initialise the linker state
  let dflags = hsc_dflags hsc_env
      pls0 = emptyPLS dflags
290

291 292
  -- (a) initialise the C dynamic linker
  initObjLinker hsc_env
293

294 295
  -- (b) Load packages from the command-line (Note [preload packages])
  pls <- linkPackages' hsc_env (preloadPackages (pkgState dflags)) pls0
296

297 298
  -- steps (c), (d) and (e)
  linkCmdLineLibs' hsc_env pls
299

300 301 302 303

linkCmdLineLibs :: HscEnv -> IO ()
linkCmdLineLibs hsc_env = do
  initDynLinker hsc_env
304
  modifyPLS_ $ \pls -> do
305 306 307 308 309 310 311
    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
312

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

      -- (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
340
      pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths
341

342
      pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls
343 344
                    cmdline_lib_specs
      maybePutStr dflags "final link ... "
345
      ok <- resolveObjs hsc_env
346 347

      -- DLLs are loaded, reset the search paths
348
      mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache
349 350 351 352 353

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

      return pls1
354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379

{- 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?
-}

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

390 391 392 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
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
438

439
  where
440 441
    dflags = hsc_dflags hsc_env

442 443
    platform = targetPlatform dflags

444 445
    preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
    preloadFailed sys_errmsg paths spec
446
       = do maybePutStr dflags "failed.\n"
447
            throwGhcExceptionIO $
448
              CmdLineError (
449 450 451 452
                    "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
453
                        intercalate "\n" (map ("   "++) paths)))
454

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

465 466 467
    preload_static_archive _paths name
       = do b <- doesFileExist name
            if not b then return False
468
                     else do if dynamicGhc
469
                                 then panic "Loading archives not supported"
470
                                 else loadArchive hsc_env name
471
                             return True
472 473


474 475 476 477 478
{- **********************************************************************

                        Link a byte-code expression

  ********************************************************************* -}
479

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

492
     -- Take lock for the actual work.
493
   ; modifyPLS $ \pls0 -> do {
494

495
     -- Link the packages and modules required
496
   ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods
497
   ; if failed ok then
498
        throwGhcExceptionIO (ProgramError "")
499 500
     else do {

501
     -- Link the expression itself
502
     let ie = itbl_env pls
503
         ce = closure_env pls
504

505
     -- Link the necessary packages and linkables
506

507 508 509
   ; 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
510
   ; [root_hvref] <- createBCOs hsc_env [resolved]
511 512
   ; fhv <- mkFinalizedHValue hsc_env root_hvref
   ; return (pls, fhv)
513
   }}}
514
   where
515
     free_names = uniqDSetToList (bcoFreeNames root_ul_bco)
516

517
     needed_mods :: [Module]
518
     needed_mods = [ nameModule n | n <- free_names,
519 520 521
                     isExternalName n,      -- Names from other modules
                     not (isWiredInName n)  -- Exclude wired-in names
                   ]                        -- (see note below)
522 523 524 525 526
        -- 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
527
dieWith :: DynFlags -> SrcSpan -> MsgDoc -> IO a
528
dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg)))
529 530


531
checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
532
checkNonStdWay dflags srcspan
533 534 535 536 537
  | 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.

538 539 540 541 542 543 544 545 546 547 548 549 550
  | 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 ++ "_"
551

552 553 554
normalObjectSuffix :: String
normalObjectSuffix = phaseInputExt StopLn

555
failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
Ian Lynagh's avatar
Ian Lynagh committed
556
failNonStd dflags srcspan = dieWith dflags srcspan $
557 558 559 560 561 562 563 564
  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."
565
    where compWay
566 567 568
            | WayDyn `elem` ways dflags = text "-dynamic"
            | WayProf `elem` ways dflags = text "-prof"
            | otherwise = text "normal"
569
          ghciWay
570 571 572
            | dynamicGhc = text "with -dynamic"
            | rtsIsProfiled = text "with -prof"
            | otherwise = text "the normal way"
573

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

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

590
      ; let {
591 592 593 594
        -- 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 ;
595

596
            linked_mods = map (moduleName.linkableModule)
597
                                (objs_loaded pls ++ bcos_loaded pls)  }
598 599 600

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

605
      ; return (lnks_needed, pkgs_needed) }
606
  where
Simon Marlow's avatar
Simon Marlow committed
607 608 609
    dflags = hsc_dflags hsc_env
    this_pkg = thisPackage dflags

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

          when (mi_boot iface) $ link_boot_mod_error mod

          let
632
            pkg = moduleUnitId mod
633 634 635 636 637 638 639
            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
640 641 642
            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
643 644
          --
          if pkg /= this_pkg
645
             then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toInstalledUnitId pkg))
646 647 648 649 650
             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
651 652


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

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

664
    while_linking_expr = text "while linking an interpreted expression"
665

666
        -- This one is a build-system bug
667

668
    get_linkable osuf mod_name      -- A home-package module
niteria's avatar
niteria committed
669
        | Just mod_info <- lookupHpt hpt mod_name
670
        = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))
671 672 673 674 675
        | 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
676
                  Found loc mod -> found loc mod
677
                  _ -> no_obj mod_name
678 679
        where
            found loc mod = do {
680 681 682 683
                -- ...and then find the linkable for it
               mb_lnk <- findObjectLinkableMaybe mod loc ;
               case mb_lnk of {
                  Nothing  -> no_obj mod ;
684
                  Just lnk -> adjust_linkable lnk
685
              }}
686

687
            adjust_linkable lnk
688 689 690
                | Just new_osuf <- replace_osuf = do
                        new_uls <- mapM (adjust_ul new_osuf)
                                        (linkableUnlinked lnk)
691
                        return lnk{ linkableUnlinked=new_uls }
692
                | otherwise =
693
                        return lnk
694

695
            adjust_ul new_osuf (DotO file) = do
696
                MASSERT(osuf `isSuffixOf` file)
697
                let file_base = fromJust (stripExtension osuf file)
698 699 700 701
                    new_file = file_base <.> new_osuf
                ok <- doesFileExist new_file
                if (not ok)
                   then dieWith dflags span $
702
                          text "cannot find object file "
703 704 705 706 707
                                <> 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
708 709 710 711 712 713 714 715 716 717
#if !MIN_VERSION_filepath(1,4,1)
    stripExtension :: String -> FilePath -> Maybe FilePath
    stripExtension []        path = Just path
    stripExtension ext@(x:_) path = stripSuffix dotExt path
        where dotExt = if isExtSeparator x then ext else '.':ext

    stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]
    stripSuffix xs ys = fmap reverse $ stripPrefix (reverse xs) (reverse ys)
#endif

718

719

720 721
{- **********************************************************************

722
              Loading a Decls statement
723 724 725

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

726
linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO ()
727
linkDecls hsc_env span cbc@CompiledByteCode{..} = do
728
    -- Initialise the linker (if it's not been done already)
729
    initDynLinker hsc_env
730 731 732 733 734 735 736

    -- 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
737
      then throwGhcExceptionIO (ProgramError "")
738 739 740
      else do

    -- Link the expression itself
741
    let ie = plusNameEnv (itbl_env pls) bc_itbls
742 743 744
        ce = closure_env pls

    -- Link the necessary packages and linkables
745
    new_bindings <- linkSomeBCOs hsc_env ie ce [cbc]
746 747 748 749
    nms_fhvs <- makeForeignNamedHValueRefs hsc_env new_bindings
    let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs
                   , itbl_env    = ie }
    return (pls2, ())
750
  where
751 752
    free_names = uniqDSetToList $
      foldr (unionUniqDSets . bcoFreeNames) emptyUniqDSet bc_bcos
753 754

    needed_mods :: [Module]
755
    needed_mods = [ nameModule n | n <- free_names,
756 757 758 759 760 761 762 763
                    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.

764 765
{- **********************************************************************

766 767
              Loading a single module

768 769
  ********************************************************************* -}

770 771
linkModule :: HscEnv -> Module -> IO ()
linkModule hsc_env mod = do
772
  initDynLinker hsc_env
773
  modifyPLS_ $ \pls -> do
774
    (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod]
775
    if (failed ok) then throwGhcExceptionIO (ProgramError "could not link module")
776
      else return pls'
777

778 779
{- **********************************************************************

780 781 782
                Link some linkables
        The linkables may consist of a mixture of
        byte-code modules and object modules
783

784 785
  ********************************************************************* -}

786
linkModules :: HscEnv -> PersistentLinkerState -> [Linkable]
787
            -> IO (PersistentLinkerState, SuccessFlag)
788
linkModules hsc_env pls linkables
789
  = mask_ $ do  -- don't want to be interrupted by ^C in here
790 791

        let (objs, bcos) = partition isObjectLinkable
792 793
                              (concatMap partitionLinkable linkables)

794
                -- Load objects first; they can't depend on BCOs
795
        (pls1, ok_flag) <- dynLinkObjs hsc_env pls objs
796 797 798 799

        if failed ok_flag then
                return (pls1, Failed)
          else do
800
                pls2 <- dynLinkBCOs hsc_env pls1 bcos
801
                return (pls2, Succeeded)
802 803 804 805 806 807 808 809


-- 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
810
     in
811
         case (li_uls_obj, li_uls_bco