Linker.hs 56.5 KB
Newer Older
1
{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections, RecordWildCards #-}
2
{-# OPTIONS_GHC -fno-cse #-}
3 4 5 6
--
--  (c) The University of Glasgow 2002-2006
--

7 8
-- -fno-cse is needed for GLOBAL_VAR's to behave properly

9 10 11 12 13
-- | 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.
14
module Linker ( getHValue, showLinkerState,
15
                linkExpr, linkDecls, unload, withExtendedLinkEnv,
16
                extendLinkEnv, deleteFromLinkEnv,
17 18
                extendLoadedPkgs,
                linkPackages,initDynLinker,linkModule,
19
                linkCmdLineLibs,
20

21 22 23
                -- Saving/restoring globals
                PersistentLinkerState, saveLinkerGlobals, restoreLinkerGlobals
        ) where
sof's avatar
sof committed
24

25
#include "HsVersions.h"
26

27 28
import GHCi
import GHCi.RemoteTypes
29
import LoadIface
30 31
import ByteCodeLink
import ByteCodeAsm
32
import ByteCodeTypes
33
import TcRnMonad
34
import Packages
35 36
import DriverPhases
import Finder
37
import HscTypes
38
import Name
39
import NameEnv
40
import NameSet
41
import UniqFM
42
import Module
43 44 45
import ListSetOps
import DynFlags
import BasicTypes
46
import Outputable
47 48 49 50
import Panic
import Util
import ErrUtils
import SrcLoc
51
import qualified Maybes
Simon Marlow's avatar
Simon Marlow committed
52
import UniqSet
53
import FastString
54
import Platform
55
import SysTools
56

57
-- Standard libraries
58
import Control.Monad
59
import Control.Applicative((<|>))
60

61 62
import Data.IORef
import Data.List
63
import Data.Maybe
64
import Control.Concurrent.MVar
65

Ian Lynagh's avatar
Ian Lynagh committed
66
import System.FilePath
67
import System.Directory
68

69
import Exception
70 71


72 73
{- **********************************************************************

74
                        The Linker's state
75

76 77 78
  ********************************************************************* -}

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

82 83 84
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.
85 86 87

The PersistentLinkerState maps Names to actual closures (for
interpreted code only), for use during linking.
88
-}
89

90
GLOBAL_VAR_M(v_PersistentLinkerState, newMVar (panic "Dynamic linker not initialised"), MVar PersistentLinkerState)
91
GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised
92

93 94 95 96 97 98
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

99 100 101
data PersistentLinkerState
   = PersistentLinkerState {

102
        -- Current global mapping from Names to their true values
103 104
        closure_env :: ClosureEnv,

105 106 107 108 109
        -- 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.
110
        itbl_env    :: !ItblEnv,
111

112 113
        -- The currently loaded interpreted modules (home package)
        bcos_loaded :: ![Linkable],
114

115 116
        -- And the currently-loaded compiled modules (home package)
        objs_loaded :: ![Linkable],
117

118 119 120
        -- The currently-loaded packages; always object code
        -- Held, as usual, in dependency order; though I am not sure if
        -- that is really important
121
        pkgs_loaded :: ![UnitId],
122

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

127

128
emptyPLS :: DynFlags -> PersistentLinkerState
129 130 131 132 133
emptyPLS _ = PersistentLinkerState {
                        closure_env = emptyNameEnv,
                        itbl_env    = emptyNameEnv,
                        pkgs_loaded = init_pkgs,
                        bcos_loaded = [],
134
                        objs_loaded = [],
135
                        temp_sos = [] }
136 137

  -- Packages that don't need loading, because the compiler
138 139 140 141
  -- 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.
142
  where init_pkgs = [rtsUnitId]
143

144

145
extendLoadedPkgs :: [UnitId] -> IO ()
146
extendLoadedPkgs pkgs =
147
  modifyPLS_ $ \s ->
148
      return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }
149

150
extendLinkEnv :: [(Name,ForeignHValue)] -> IO ()
151
extendLinkEnv new_bindings =
152 153 154 155
  modifyPLS_ $ \pls -> do
    let ce = closure_env pls
    let new_ce = extendClosureEnv ce new_bindings
    return pls{ closure_env = new_ce }
156

157
deleteFromLinkEnv :: [Name] -> IO ()
158
deleteFromLinkEnv to_remove =
159 160 161 162
  modifyPLS_ $ \pls -> do
    let ce = closure_env pls
    let new_ce = delListFromNameEnv ce to_remove
    return pls{ closure_env = new_ce }
163

164 165 166 167 168
-- | 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.
169
getHValue :: HscEnv -> Name -> IO ForeignHValue
170
getHValue hsc_env name = do
171
  initDynLinker hsc_env
172
  pls <- modifyPLS $ \pls -> do
173
           if (isExternalName name) then do
174 175
             (pls', ok) <- linkDependencies hsc_env pls noSrcSpan
                              [nameModule name]
176
             if (failed ok) then throwGhcExceptionIO (ProgramError "")
177 178 179
                            else return (pls', pls')
            else
             return (pls, pls)
180 181 182 183 184 185 186 187 188 189
  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)
190

191 192 193 194
linkDependencies :: HscEnv -> PersistentLinkerState
                 -> SrcSpan -> [Module]
                 -> IO (PersistentLinkerState, SuccessFlag)
linkDependencies hsc_env pls span needed_mods = do
195
--   initDynLinker (hsc_dflags hsc_env)
196 197
   let hpt = hsc_HPT hsc_env
       dflags = hsc_dflags hsc_env
198 199 200 201
   -- 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.
202 203
   maybe_normal_osuf <- checkNonStdWay dflags span

204
   -- Find what packages and linkables are required
205
   (lnks, pkgs) <- getLinkDeps hsc_env hpt pls
206
                               maybe_normal_osuf span needed_mods
207

208
   -- Link the packages and modules required
209 210
   pls1 <- linkPackages' hsc_env pkgs pls
   linkModules hsc_env pls1 lnks
211

212

213 214
-- | Temporarily extend the linker state.

215
withExtendedLinkEnv :: (ExceptionMonad m) =>
216
                       [(Name,ForeignHValue)] -> m a -> m a
217
withExtendedLinkEnv new_env action
218
    = gbracket (liftIO $ extendLinkEnv new_env)
219 220
               (\_ -> reset_old_env)
               (\_ -> action)
221
    where
222 223 224 225 226
        -- 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.
227
          reset_old_env = liftIO $ do
228
            modifyPLS_ $ \pls ->
229 230
                let cur = closure_env pls
                    new = delListFromNameEnv cur (map fst new_env)
231
                in return pls{ closure_env = new }
232

233

234
-- | Display the persistent linker state.
235 236
showLinkerState :: DynFlags -> IO ()
showLinkerState dflags
237
  = do pls <- readIORef v_PersistentLinkerState >>= readMVar
238
       log_action dflags dflags NoReason SevDump noSrcSpan defaultDumpStyle
239
                 (vcat [text "----- Linker state -----",
240 241 242
                        text "Pkgs:" <+> ppr (pkgs_loaded pls),
                        text "Objs:" <+> ppr (objs_loaded pls),
                        text "BCOs:" <+> ppr (bcos_loaded pls)])
243

244

245 246 247 248 249
{- **********************************************************************

                        Initialisation

  ********************************************************************* -}
250

251 252 253 254 255 256 257 258 259 260
-- | 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
261
--     in @ldInputs@,
262 263 264 265 266 267 268
--
--  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.
--
269 270
initDynLinker :: HscEnv -> IO ()
initDynLinker hsc_env =
271
  modifyPLS_ $ \pls0 -> do
272 273 274
    done <- readIORef v_InitLinkerDone
    if done then return pls0
            else do writeIORef v_InitLinkerDone True
275
                    reallyInitDynLinker hsc_env
276

277 278 279 280 281
reallyInitDynLinker :: HscEnv -> IO PersistentLinkerState
reallyInitDynLinker hsc_env = do
  -- Initialise the linker state
  let dflags = hsc_dflags hsc_env
      pls0 = emptyPLS dflags
282

283 284
  -- (a) initialise the C dynamic linker
  initObjLinker hsc_env
285

286 287
  -- (b) Load packages from the command-line (Note [preload packages])
  pls <- linkPackages' hsc_env (preloadPackages (pkgState dflags)) pls0
288

289 290
  -- steps (c), (d) and (e)
  linkCmdLineLibs' hsc_env pls
291

292 293 294 295

linkCmdLineLibs :: HscEnv -> IO ()
linkCmdLineLibs hsc_env = do
  initDynLinker hsc_env
296
  modifyPLS_ $ \pls -> do
297 298 299 300 301 302 303
    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
304

305
      -- (c) Link libraries from the command-line
306
      let minus_ls = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ]
307
      libspecs <- mapM (locateLib hsc_env False lib_paths) minus_ls
308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331

      -- (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
332
      pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths
333

334
      pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls
335 336
                    cmdline_lib_specs
      maybePutStr dflags "final link ... "
337
      ok <- resolveObjs hsc_env
338 339

      -- DLLs are loaded, reset the search paths
340
      mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache
341 342 343 344 345

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

      return pls1
346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371

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

372 373
classifyLdInput :: DynFlags -> FilePath -> IO (Maybe LibrarySpec)
classifyLdInput dflags f
374 375
  | isObjectFilename platform f = return (Just (Object f))
  | isDynLibFilename platform f = return (Just (DLLPath f))
376
  | otherwise          = do
377
        log_action dflags dflags NoReason SevInfo noSrcSpan defaultUserStyle
378
            (text ("Warning: ignoring unrecognised input `" ++ f ++ "'"))
379
        return Nothing
380
    where platform = targetPlatform dflags
381

382 383 384 385 386 387 388 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
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
430

431
  where
432 433
    dflags = hsc_dflags hsc_env

434 435
    platform = targetPlatform dflags

436 437
    preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
    preloadFailed sys_errmsg paths spec
438
       = do maybePutStr dflags "failed.\n"
439
            throwGhcExceptionIO $
440
              CmdLineError (
441 442 443 444
                    "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
445
                        intercalate "\n" (map ("   "++) paths)))
446

447
    -- Not interested in the paths in the static case.
Ian Lynagh's avatar
Ian Lynagh committed
448
    preload_static _paths name
449
       = do b <- doesFileExist name
450 451
            if not b then return (False, pls)
                     else if dynamicGhc
452
                             then  do pls1 <- dynLoadObjs hsc_env pls [name]
453
                                      return (True, pls1)
454
                             else  do loadObj hsc_env name
455 456
                                      return (True, pls)

457 458 459
    preload_static_archive _paths name
       = do b <- doesFileExist name
            if not b then return False
460
                     else do if dynamicGhc
461
                                 then panic "Loading archives not supported"
462
                                 else loadArchive hsc_env name
463
                             return True
464 465


466 467 468 469 470
{- **********************************************************************

                        Link a byte-code expression

  ********************************************************************* -}
471

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

484
     -- Take lock for the actual work.
485
   ; modifyPLS $ \pls0 -> do {
486

487
     -- Link the packages and modules required
488
   ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods
489
   ; if failed ok then
490
        throwGhcExceptionIO (ProgramError "")
491 492
     else do {

493
     -- Link the expression itself
494
     let ie = itbl_env pls
495
         ce = closure_env pls
496

497
     -- Link the necessary packages and linkables
498

499 500 501
   ; 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
502
   ; [root_hvref] <- createBCOs hsc_env [resolved]
503 504
   ; fhv <- mkFinalizedHValue hsc_env root_hvref
   ; return (pls, fhv)
505
   }}}
506
   where
507
     free_names = nameSetElems (bcoFreeNames root_ul_bco)
508

509
     needed_mods :: [Module]
510
     needed_mods = [ nameModule n | n <- free_names,
511 512 513
                     isExternalName n,      -- Names from other modules
                     not (isWiredInName n)  -- Exclude wired-in names
                   ]                        -- (see note below)
514 515 516 517 518
        -- 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
519
dieWith :: DynFlags -> SrcSpan -> MsgDoc -> IO a
520
dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg)))
521 522


523
checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
524
checkNonStdWay dflags srcspan
525 526 527 528 529
  | 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.

530 531 532 533 534 535 536 537 538 539 540 541 542
  | 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 ++ "_"
543

544 545 546
normalObjectSuffix :: String
normalObjectSuffix = phaseInputExt StopLn

547
failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
Ian Lynagh's avatar
Ian Lynagh committed
548
failNonStd dflags srcspan = dieWith dflags srcspan $
549 550 551 552 553 554 555 556
  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."
557
    where compWay
558 559 560
            | WayDyn `elem` ways dflags = text "-dynamic"
            | WayProf `elem` ways dflags = text "-prof"
            | otherwise = text "normal"
561
          ghciWay
562 563 564
            | dynamicGhc = text "with -dynamic"
            | rtsIsProfiled = text "with -prof"
            | otherwise = text "the normal way"
565

566 567
getLinkDeps :: HscEnv -> HomePackageTable
            -> PersistentLinkerState
568
            -> Maybe FilePath                   -- replace object suffices?
569 570
            -> SrcSpan                          -- for error messages
            -> [Module]                         -- If you need these
571
            -> IO ([Linkable], [UnitId])     -- ... then link these first
572
-- Fails with an IO exception if it can't find enough files
573

574
getLinkDeps hsc_env hpt pls replace_osuf span mods
575
-- Find all the packages and linkables that a set of modules depends on
576
 = do {
577
        -- 1.  Find the dependent home-pkg-modules/packages from each iface
578 579
        -- (omitting modules from the interactive package, which is already linked)
      ; (mods_s, pkgs_s) <- follow_deps (filterOut isInteractiveModule mods)
580
                                        emptyUniqSet emptyUniqSet;
581

582
      ; let {
583 584 585 586
        -- 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 ;
587

588
            linked_mods = map (moduleName.linkableModule)
589
                                (objs_loaded pls ++ bcos_loaded pls)  }
590 591 592

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

597
      ; return (lnks_needed, pkgs_needed) }
598
  where
Simon Marlow's avatar
Simon Marlow committed
599 600 601
    dflags = hsc_dflags hsc_env
    this_pkg = thisPackage dflags

602 603 604 605 606 607 608
        -- 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
                -> UniqSet ModuleName         -- accum. module dependencies
609 610
                -> UniqSet UnitId          -- accum. package dependencies
                -> IO ([ModuleName], [UnitId]) -- result
Simon Marlow's avatar
Simon Marlow committed
611
    follow_deps []     acc_mods acc_pkgs
612
        = return (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
Simon Marlow's avatar
Simon Marlow committed
613
    follow_deps (mod:mods) acc_mods acc_pkgs
614 615 616 617
        = do
          mb_iface <- initIfaceCheck hsc_env $
                        loadInterface msg mod (ImportByUser False)
          iface <- case mb_iface of
618
                    Maybes.Failed err      -> throwGhcExceptionIO (ProgramError (showSDoc dflags err))
619
                    Maybes.Succeeded iface -> return iface
620 621 622 623

          when (mi_boot iface) $ link_boot_mod_error mod

          let
624
            pkg = moduleUnitId mod
625 626 627 628 629 630 631 632 633
            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

            boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps
            acc_mods'  = addListToUniqSet acc_mods (moduleName mod : mod_deps)
634
            acc_pkgs'  = addListToUniqSet acc_pkgs $ map fst pkg_deps
635 636 637 638 639 640 641 642
          --
          if pkg /= this_pkg
             then follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg)
             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
643 644


645
    link_boot_mod_error mod =
646
        throwGhcExceptionIO (ProgramError (showSDoc dflags (
647
            text "module" <+> ppr mod <+>
Simon Marlow's avatar
Simon Marlow committed
648
            text "cannot be linked; it is only available as a boot module")))
649

650
    no_obj :: Outputable a => a -> IO b
Ian Lynagh's avatar
Ian Lynagh committed
651
    no_obj mod = dieWith dflags span $
652
                     text "cannot find object file for module " <>
653 654 655
                        quotes (ppr mod) $$
                     while_linking_expr

656
    while_linking_expr = text "while linking an interpreted expression"
657

658
        -- This one is a build-system bug
659

660
    get_linkable osuf mod_name      -- A home-package module
661
        | Just mod_info <- lookupUFM hpt mod_name
662
        = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))
663 664 665 666 667
        | 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
668
                  Found loc mod -> found loc mod
669
                  _ -> no_obj mod_name
670 671
        where
            found loc mod = do {
672 673 674 675
                -- ...and then find the linkable for it
               mb_lnk <- findObjectLinkableMaybe mod loc ;
               case mb_lnk of {
                  Nothing  -> no_obj mod ;
676
                  Just lnk -> adjust_linkable lnk
677
              }}
678

679
            adjust_linkable lnk
680 681 682
                | Just new_osuf <- replace_osuf = do
                        new_uls <- mapM (adjust_ul new_osuf)
                                        (linkableUnlinked lnk)
683
                        return lnk{ linkableUnlinked=new_uls }
684
                | otherwise =
685
                        return lnk
686

687
            adjust_ul new_osuf (DotO file) = do
688
                MASSERT(osuf `isSuffixOf` file)
689
                let file_base = fromJust (stripExtension osuf file)
690 691 692 693
                    new_file = file_base <.> new_osuf
                ok <- doesFileExist new_file
                if (not ok)
                   then dieWith dflags span $
694
                          text "cannot find object file "
695 696 697 698 699
                                <> 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
700

701

702 703
{- **********************************************************************

704
              Loading a Decls statement
705 706 707

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

708
linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO ()
709
linkDecls hsc_env span cbc@CompiledByteCode{..} = do
710
    -- Initialise the linker (if it's not been done already)
711
    initDynLinker hsc_env
712 713 714 715 716 717 718

    -- 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
719
      then throwGhcExceptionIO (ProgramError "")
720 721 722
      else do

    -- Link the expression itself
723
    let ie = plusNameEnv (itbl_env pls) bc_itbls
724 725 726
        ce = closure_env pls

    -- Link the necessary packages and linkables
727
    new_bindings <- linkSomeBCOs hsc_env ie ce [cbc]
728 729 730 731
    nms_fhvs <- makeForeignNamedHValueRefs hsc_env new_bindings
    let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs
                   , itbl_env    = ie }
    return (pls2, ())
732
  where
733
    free_names =  concatMap (nameSetElems . bcoFreeNames) bc_bcos
734 735

    needed_mods :: [Module]
736
    needed_mods = [ nameModule n | n <- free_names,
737 738 739 740 741 742 743 744
                    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.

745 746
{- **********************************************************************

747 748
              Loading a single module

749 750
  ********************************************************************* -}

751 752
linkModule :: HscEnv -> Module -> IO ()
linkModule hsc_env mod = do
753
  initDynLinker hsc_env
754
  modifyPLS_ $ \pls -> do
755
    (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod]
756
    if (failed ok) then throwGhcExceptionIO (ProgramError "could not link module")
757
      else return pls'
758

759 760
{- **********************************************************************

761 762 763
                Link some linkables
        The linkables may consist of a mixture of
        byte-code modules and object modules
764

765 766
  ********************************************************************* -}

767
linkModules :: HscEnv -> PersistentLinkerState -> [Linkable]
768
            -> IO (PersistentLinkerState, SuccessFlag)
769
linkModules hsc_env pls linkables
770
  = mask_ $ do  -- don't want to be interrupted by ^C in here
771 772

        let (objs, bcos) = partition isObjectLinkable
773 774
                              (concatMap partitionLinkable linkables)

775
                -- Load objects first; they can't depend on BCOs
776
        (pls1, ok_flag) <- dynLinkObjs hsc_env pls objs
777 778 779 780

        if failed ok_flag then
                return (pls1, Failed)
          else do
781
                pls2 <- dynLinkBCOs hsc_env pls1 bcos
782
                return (pls2, Succeeded)
783 784 785 786 787 788 789 790


-- 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
791
     in
792
         case (li_uls_obj, li_uls_bco) of
Ian Lynagh's avatar
Ian Lynagh committed
793 794 795
            (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj},
                           li {linkableUnlinked=li_uls_bco}]
            _ -> [li]
796

797
findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
798 799 800 801
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
802
        _    -> pprPanic "findModuleLinkable" (ppr mod)
803 804 805

linkableInSet :: Linkable -> [Linkable] -> Bool
linkableInSet l objs_loaded =
806
  case findModuleLinkable_maybe objs_loaded (linkableModule l) of
807 808
        Nothing -> False
        Just m  -> linkableTime l == linkableTime m