Linker.lhs 53.1 KB
Newer Older
1
%
Gabor Greif's avatar
typo  
Gabor Greif committed
2
% (c) The University of Glasgow 2005-2012
3 4
%
\begin{code}
5 6 7 8
{-# LANGUAGE CPP, NondecreasingIndentation #-}
{-# OPTIONS_GHC -fno-cse #-}
-- -fno-cse is needed for GLOBAL_VAR's to behave properly

9 10 11 12 13 14
-- | 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.

15
module Linker ( getHValue, showLinkerState,
16
                linkExpr, linkDecls, unload, withExtendedLinkEnv,
17
                extendLinkEnv, deleteFromLinkEnv,
18 19
                extendLoadedPkgs,
                linkPackages,initDynLinker,linkModule,
20

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

25
#include "HsVersions.h"
26

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

57
-- Standard libraries
58
import Control.Monad
59

60 61
import Data.IORef
import Data.List
62
import Control.Concurrent.MVar
63

Ian Lynagh's avatar
Ian Lynagh committed
64
import System.FilePath
65
import System.IO
Simon Marlow's avatar
Simon Marlow committed
66
import System.Directory hiding (findFile)
67

68
import Distribution.Package hiding (depends, mkPackageKey, PackageKey)
Ian Lynagh's avatar
Ian Lynagh committed
69

70
import Exception
71 72 73 74
\end{code}


%************************************************************************
75 76 77
%*                                                                      *
                        The Linker's state
%*                                                                      *
78 79
%************************************************************************

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

83 84 85
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.
86 87 88 89 90

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

\begin{code}
91
GLOBAL_VAR_M(v_PersistentLinkerState, newMVar (panic "Dynamic linker not initialised"), MVar PersistentLinkerState)
92
GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised
93

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

100 101 102
data PersistentLinkerState
   = PersistentLinkerState {

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

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

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

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

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

125
emptyPLS :: DynFlags -> PersistentLinkerState
126 127 128 129 130
emptyPLS _ = PersistentLinkerState {
                        closure_env = emptyNameEnv,
                        itbl_env    = emptyNameEnv,
                        pkgs_loaded = init_pkgs,
                        bcos_loaded = [],
131
                        objs_loaded = [] }
132 133

  -- Packages that don't need loading, because the compiler
134 135 136 137
  -- 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.
138
  where init_pkgs = [rtsPackageKey]
139

140

141
extendLoadedPkgs :: [PackageKey] -> IO ()
142
extendLoadedPkgs pkgs =
143
  modifyPLS_ $ \s ->
144
      return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }
145

146 147
extendLinkEnv :: [(Name,HValue)] -> IO ()
-- Automatically discards shadowed bindings
148
extendLinkEnv new_bindings =
149
  modifyPLS_ $ \pls ->
150 151
    let new_closure_env = extendClosureEnv (closure_env pls) new_bindings
    in return pls{ closure_env = new_closure_env }
152

153
deleteFromLinkEnv :: [Name] -> IO ()
154
deleteFromLinkEnv to_remove =
155
  modifyPLS_ $ \pls ->
156 157
    let new_closure_env = delListFromNameEnv (closure_env pls) to_remove
    in return pls{ closure_env = new_closure_env }
158

159 160 161 162 163
-- | 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.
164 165
getHValue :: HscEnv -> Name -> IO HValue
getHValue hsc_env name = do
166
  initDynLinker (hsc_dflags hsc_env)
167
  pls <- modifyPLS $ \pls -> do
168 169
           if (isExternalName name) then do
             (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [nameModule name]
170
             if (failed ok) then throwGhcExceptionIO (ProgramError "")
171 172 173 174
                            else return (pls', pls')
            else
             return (pls, pls)
  lookupName (closure_env pls) name
175

176 177 178 179
linkDependencies :: HscEnv -> PersistentLinkerState
                 -> SrcSpan -> [Module]
                 -> IO (PersistentLinkerState, SuccessFlag)
linkDependencies hsc_env pls span needed_mods = do
180
--   initDynLinker (hsc_dflags hsc_env)
181 182
   let hpt = hsc_HPT hsc_env
       dflags = hsc_dflags hsc_env
183 184 185 186
   -- 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.
187 188
   maybe_normal_osuf <- checkNonStdWay dflags span

189
   -- Find what packages and linkables are required
190
   (lnks, pkgs) <- getLinkDeps hsc_env hpt pls
191
                               maybe_normal_osuf span needed_mods
192

193
   -- Link the packages and modules required
194 195
   pls1 <- linkPackages' dflags pkgs pls
   linkModules dflags pls1 lnks
196

197

198 199
-- | Temporarily extend the linker state.

200 201
withExtendedLinkEnv :: (MonadIO m, ExceptionMonad m) =>
                       [(Name,HValue)] -> m a -> m a
202
withExtendedLinkEnv new_env action
203
    = gbracket (liftIO $ extendLinkEnv new_env)
204 205
               (\_ -> reset_old_env)
               (\_ -> action)
206
    where
207 208 209 210 211
        -- 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.
212
          reset_old_env = liftIO $ do
213
            modifyPLS_ $ \pls ->
214 215
                let cur = closure_env pls
                    new = delListFromNameEnv cur (map fst new_env)
216
                in return pls{ closure_env = new }
217

218 219 220 221
-- filterNameMap removes from the environment all entries except
-- those for a given set of modules;
-- Note that this removes all *local* (i.e. non-isExternal) names too
-- (these are the temporary bindings from the command line).
222 223
-- Used to filter both the ClosureEnv and ItblEnv

224
filterNameMap :: [Module] -> NameEnv (Name, a) -> NameEnv (Name, a)
225
filterNameMap mods env
226 227
   = filterNameEnv keep_elt env
   where
228 229
     keep_elt (n,_) = isExternalName n
                      && (nameModule n `elem` mods)
230 231


232
-- | Display the persistent linker state.
233 234
showLinkerState :: DynFlags -> IO ()
showLinkerState dflags
235
  = do pls <- readIORef v_PersistentLinkerState >>= readMVar
Ian Lynagh's avatar
Ian Lynagh committed
236
       log_action dflags dflags SevDump noSrcSpan defaultDumpStyle
237
                 (vcat [text "----- Linker state -----",
238 239 240
                        text "Pkgs:" <+> ppr (pkgs_loaded pls),
                        text "Objs:" <+> ppr (objs_loaded pls),
                        text "BCOs:" <+> ppr (bcos_loaded pls)])
241 242
\end{code}

243 244

%************************************************************************
245
%*                                                                      *
246
\subsection{Initialisation}
247
%*                                                                      *
248 249 250
%************************************************************************

\begin{code}
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
initDynLinker :: DynFlags -> IO ()
270
initDynLinker dflags =
271
  modifyPLS_ $ \pls0 -> do
272 273 274 275 276 277 278 279
    done <- readIORef v_InitLinkerDone
    if done then return pls0
            else do writeIORef v_InitLinkerDone True
                    reallyInitDynLinker dflags

reallyInitDynLinker :: DynFlags -> IO PersistentLinkerState
reallyInitDynLinker dflags =
    do  {  -- Initialise the linker state
280
          let pls0 = emptyPLS dflags
281

282 283
          -- (a) initialise the C dynamic linker
        ; initObjLinker
284

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

288
          -- (c) Link libraries from the command-line
289 290
        ; let cmdline_ld_inputs = ldInputs dflags
        ; let minus_ls = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ]
291 292
        ; let lib_paths = libraryPaths dflags
        ; libspecs <- mapM (locateLib dflags False lib_paths) minus_ls
293

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

298
          -- (e) Link any MacOS frameworks
299
        ; let platform = targetPlatform dflags
300 301 302 303 304 305
        ; let framework_paths = if platformUsesFrameworks platform
                                then frameworkPaths dflags
                                else []
        ; let frameworks = if platformUsesFrameworks platform
                           then cmdlineFrameworks dflags
                           else []
306
          -- Finally do (c),(d),(e)
307
        ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ]
308
                               ++ libspecs
309 310 311
                               ++ map Framework frameworks
        ; if null cmdline_lib_specs then return pls
                                    else do
312

313
        { mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs
314 315
        ; maybePutStr dflags "final link ... "
        ; ok <- resolveObjs
316

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

320
        ; return pls
321
        }}
322

323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348

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

349 350
classifyLdInput :: DynFlags -> FilePath -> IO (Maybe LibrarySpec)
classifyLdInput dflags f
351 352
  | isObjectFilename platform f = return (Just (Object f))
  | isDynLibFilename platform f = return (Just (DLLPath f))
353
  | otherwise          = do
Ian Lynagh's avatar
Ian Lynagh committed
354
        log_action dflags dflags SevInfo noSrcSpan defaultUserStyle
355
            (text ("Warning: ignoring unrecognised input `" ++ f ++ "'"))
356
        return Nothing
357
    where platform = targetPlatform dflags
358

359 360
preloadLib :: DynFlags -> [String] -> [String] -> LibrarySpec -> IO ()
preloadLib dflags lib_paths framework_paths lib_spec
361 362 363
  = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
       case lib_spec of
          Object static_ish
364
             -> do b <- preload_static lib_paths static_ish
365
                   maybePutStrLn dflags (if b  then "done"
366 367 368 369 370 371 372
                                                else "not found")

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

373
          DLL dll_unadorned
374
             -> do maybe_errstr <- loadDLL (mkSOName platform dll_unadorned)
375 376
                   case maybe_errstr of
                      Nothing -> maybePutStrLn dflags "done"
Austin Seipp's avatar
Austin Seipp committed
377 378 379 380 381 382 383 384 385 386
                      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.
                        err2 <- loadDLL $ ("lib" ++ dll_unadorned) <.> "so"
                        case err2 of
                          Nothing -> maybePutStrLn dflags "done"
                          Just _  -> preloadFailed mm lib_paths lib_spec
387

388 389
          DLLPath dll_path
             -> do maybe_errstr <- loadDLL dll_path
390 391 392 393
                   case maybe_errstr of
                      Nothing -> maybePutStrLn dflags "done"
                      Just mm -> preloadFailed mm lib_paths lib_spec

394
          Framework framework ->
395 396 397 398 399 400
              if platformUsesFrameworks (targetPlatform dflags)
              then do maybe_errstr <- loadFramework framework_paths framework
                      case maybe_errstr of
                         Nothing -> maybePutStrLn dflags "done"
                         Just mm -> preloadFailed mm framework_paths lib_spec
              else panic "preloadLib Framework"
Ian Lynagh's avatar
Ian Lynagh committed
401

402
  where
403 404
    platform = targetPlatform dflags

405 406
    preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
    preloadFailed sys_errmsg paths spec
407
       = do maybePutStr dflags "failed.\n"
408
            throwGhcExceptionIO $
409
              CmdLineError (
410 411 412 413 414
                    "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
                        (concat (intersperse "\n" (map ("   "++) paths)))))
415

416
    -- Not interested in the paths in the static case.
Ian Lynagh's avatar
Ian Lynagh committed
417
    preload_static _paths name
418
       = do b <- doesFileExist name
419 420 421 422 423
            if not b then return False
                     else do if dynamicGhc
                                 then dynLoadObjs dflags [name]
                                 else loadObj name
                             return True
424 425 426
    preload_static_archive _paths name
       = do b <- doesFileExist name
            if not b then return False
427
                     else do if dynamicGhc
428 429 430
                                 then panic "Loading archives not supported"
                                 else loadArchive name
                             return True
431 432 433
\end{code}


434
%************************************************************************
435 436 437
%*                                                                      *
                Link a byte-code expression
%*                                                                      *
438 439 440
%************************************************************************

\begin{code}
441
-- | Link a single expression, /including/ first linking packages and
442 443
-- modules that this expression depends on.
--
444 445
-- Raises an IO exception ('ProgramError') if it can't find a compiled
-- version of the dependents to link.
446
--
447
linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue
448
linkExpr hsc_env span root_ul_bco
449 450
  = do {
     -- Initialise the linker (if it's not been done already)
451 452
     let dflags = hsc_dflags hsc_env
   ; initDynLinker dflags
453

454
     -- Take lock for the actual work.
455
   ; modifyPLS $ \pls0 -> do {
456

457
     -- Link the packages and modules required
458
   ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods
459
   ; if failed ok then
460
        throwGhcExceptionIO (ProgramError "")
461 462
     else do {

463
     -- Link the expression itself
464
     let ie = itbl_env pls
465
         ce = closure_env pls
466

467
     -- Link the necessary packages and linkables
468
   ; (_, (root_hval:_)) <- linkSomeBCOs dflags False ie ce [root_ul_bco]
469 470
   ; return (pls, root_hval)
   }}}
471
   where
472 473
     free_names = nameSetToList (bcoFreeNames root_ul_bco)

474
     needed_mods :: [Module]
475
     needed_mods = [ nameModule n | n <- free_names,
476 477 478
                     isExternalName n,      -- Names from other modules
                     not (isWiredInName n)  -- Exclude wired-in names
                   ]                        -- (see note below)
479 480 481 482 483
        -- 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
484
dieWith :: DynFlags -> SrcSpan -> MsgDoc -> IO a
485
dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg)))
486 487


488 489 490 491
checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
checkNonStdWay dflags srcspan =
  if interpWays == haskellWays
      then return Nothing
492 493 494 495 496 497 498 499 500
    -- see #3604: object files compiled for way "dyn" need to link to the
    -- dynamic packages, so we can't load them into a statically-linked GHCi.
    -- we have to treat "dyn" in the same way as "prof".
    --
    -- In the future when GHCi is dynamically linked we should be able to relax
    -- this, but they we may have to make it possible to load either ordinary
    -- .o files or -dynamic .o files into GHCi (currently that's not possible
    -- because the dynamic objects contain refs to e.g. __stginit_base_Prelude_dyn
    -- whereas we have __stginit_base_Prelude_.
501
      else if objectSuf dflags == normalObjectSuffix && not (null haskellWays)
502
      then failNonStd dflags srcspan
503
      else return $ Just $ if dynamicGhc
504 505 506
                           then "dyn_o"
                           else "o"
    where haskellWays = filter (not . wayRTSOnly) (ways dflags)
507

508 509 510
normalObjectSuffix :: String
normalObjectSuffix = phaseInputExt StopLn

511
failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
Ian Lynagh's avatar
Ian Lynagh committed
512
failNonStd dflags srcspan = dieWith dflags srcspan $
Ian Lynagh's avatar
Ian Lynagh committed
513
  ptext (sLit "Dynamic linking required, but this is a non-standard build (eg. prof).") $$
514
  ptext (sLit "You need to build the program twice: once the") <+> ghciWay <+> ptext (sLit "way, and then") $$
Ian Lynagh's avatar
Ian Lynagh committed
515
  ptext (sLit "in the desired way using -osuf to set the object file suffix.")
516
    where ghciWay = if dynamicGhc
517 518
                    then ptext (sLit "dynamic")
                    else ptext (sLit "normal")
519

520 521
getLinkDeps :: HscEnv -> HomePackageTable
            -> PersistentLinkerState
522
            -> Maybe FilePath                   -- replace object suffices?
523 524
            -> SrcSpan                          -- for error messages
            -> [Module]                         -- If you need these
525
            -> IO ([Linkable], [PackageKey])     -- ... then link these first
526
-- Fails with an IO exception if it can't find enough files
527

528
getLinkDeps hsc_env hpt pls replace_osuf span mods
529
-- Find all the packages and linkables that a set of modules depends on
530
 = do {
531
        -- 1.  Find the dependent home-pkg-modules/packages from each iface
532 533
        -- (omitting modules from the interactive package, which is already linked)
      ; (mods_s, pkgs_s) <- follow_deps (filterOut isInteractiveModule mods)
534
                                        emptyUniqSet emptyUniqSet;
535

536
      ; let {
537 538 539 540
        -- 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 ;
541

542
            linked_mods = map (moduleName.linkableModule)
543
                                (objs_loaded pls ++ bcos_loaded pls)  }
544 545 546 547

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

551
      ; return (lnks_needed, pkgs_needed) } 
552
  where
Simon Marlow's avatar
Simon Marlow committed
553 554 555
    dflags = hsc_dflags hsc_env
    this_pkg = thisPackage dflags

Simon Marlow's avatar
Simon Marlow committed
556 557 558 559 560 561 562
        -- 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
563 564
                -> UniqSet PackageKey          -- accum. package dependencies
                -> IO ([ModuleName], [PackageKey]) -- result
Simon Marlow's avatar
Simon Marlow committed
565
    follow_deps []     acc_mods acc_pkgs
566
        = return (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
Simon Marlow's avatar
Simon Marlow committed
567
    follow_deps (mod:mods) acc_mods acc_pkgs
568 569 570 571
        = do
          mb_iface <- initIfaceCheck hsc_env $
                        loadInterface msg mod (ImportByUser False)
          iface <- case mb_iface of
572
                    Maybes.Failed err      -> throwGhcExceptionIO (ProgramError (showSDoc dflags err))
573
                    Maybes.Succeeded iface -> return iface
574 575 576 577

          when (mi_boot iface) $ link_boot_mod_error mod

          let
578
            pkg = modulePackageKey mod
579 580 581 582 583 584 585 586 587
            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)
588
            acc_pkgs'  = addListToUniqSet acc_pkgs $ map fst pkg_deps
589 590 591 592 593 594 595 596
          --
          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
597 598


599
    link_boot_mod_error mod =
600
        throwGhcExceptionIO (ProgramError (showSDoc dflags (
601
            text "module" <+> ppr mod <+>
Simon Marlow's avatar
Simon Marlow committed
602
            text "cannot be linked; it is only available as a boot module")))
603

604
    no_obj :: Outputable a => a -> IO b
Ian Lynagh's avatar
Ian Lynagh committed
605
    no_obj mod = dieWith dflags span $
606 607 608 609
                     ptext (sLit "cannot find object file for module ") <>
                        quotes (ppr mod) $$
                     while_linking_expr

Ian Lynagh's avatar
Ian Lynagh committed
610
    while_linking_expr = ptext (sLit "while linking an interpreted expression")
611

612
        -- This one is a build-system bug
613

614
    get_linkable osuf mod_name      -- A home-package module
615 616 617 618 619 620 621 622 623
        | Just mod_info <- lookupUFM hpt mod_name
        = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))
        | 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
                  Found loc mod -> found loc mod
                  _ -> no_obj mod_name
624 625
        where
            found loc mod = do {
626 627 628 629 630 631
                -- ...and then find the linkable for it
               mb_lnk <- findObjectLinkableMaybe mod loc ;
               case mb_lnk of {
                  Nothing  -> no_obj mod ;
                  Just lnk -> adjust_linkable lnk
              }}
632

633
            adjust_linkable lnk
634 635 636
                | Just new_osuf <- replace_osuf = do
                        new_uls <- mapM (adjust_ul new_osuf)
                                        (linkableUnlinked lnk)
637
                        return lnk{ linkableUnlinked=new_uls }
638 639 640
                | otherwise =
                        return lnk

641
            adjust_ul new_osuf (DotO file) = do
642
                MASSERT(osuf `isSuffixOf` file)
643
                let file_base = dropTail (length osuf + 1) file
644 645 646 647 648 649 650 651 652 653
                    new_file = file_base <.> new_osuf
                ok <- doesFileExist new_file
                if (not ok)
                   then dieWith dflags span $
                          ptext (sLit "cannot find normal object file ")
                                <> 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
654
\end{code}
655

656 657

%************************************************************************
658
%*                                                                      *
659
              Loading a Decls statement
660
%*                                                                      *
661 662 663 664 665 666 667 668 669 670 671 672 673 674
%************************************************************************
\begin{code}
linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO () --[HValue]
linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv) = do
    -- Initialise the linker (if it's not been done already)
    let dflags = hsc_dflags hsc_env
    initDynLinker dflags

    -- 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
675
      then throwGhcExceptionIO (ProgramError "")
676 677 678 679 680 681 682
      else do

    -- Link the expression itself
    let ie = plusNameEnv (itbl_env pls) itblEnv
        ce = closure_env pls

    -- Link the necessary packages and linkables
683
    (final_gce, _) <- linkSomeBCOs dflags False ie ce unlinkedBCOs
684 685 686 687 688 689 690
    let pls2 = pls { closure_env = final_gce,
                     itbl_env    = ie }
    return (pls2, ()) --hvals)
  where
    free_names =  concatMap (nameSetToList . bcoFreeNames) unlinkedBCOs

    needed_mods :: [Module]
691
    needed_mods = [ nameModule n | n <- free_names,
692 693 694 695 696 697 698 699 700 701 702
                    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.
\end{code}



703
%************************************************************************
704
%*                                                                      *
705
              Loading a single module
706
%*                                                                      *
707 708
%************************************************************************

709
\begin{code}
710 711 712
linkModule :: HscEnv -> Module -> IO ()
linkModule hsc_env mod = do
  initDynLinker (hsc_dflags hsc_env)
713
  modifyPLS_ $ \pls -> do
714
    (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod]
715
    if (failed ok) then throwGhcExceptionIO (ProgramError "could not link module")
716
      else return pls'
717
\end{code}
718 719

%************************************************************************
720 721 722 723 724
%*                                                                      *
                Link some linkables
        The linkables may consist of a mixture of
        byte-code modules and object modules
%*                                                                      *
725 726 727
%************************************************************************

\begin{code}
728 729 730
linkModules :: DynFlags -> PersistentLinkerState -> [Linkable]
            -> IO (PersistentLinkerState, SuccessFlag)
linkModules dflags pls linkables
731
  = mask_ $ do  -- don't want to be interrupted by ^C in here
732 733

        let (objs, bcos) = partition isObjectLinkable
734 735
                              (concatMap partitionLinkable linkables)

736 737 738 739 740 741
                -- Load objects first; they can't depend on BCOs
        (pls1, ok_flag) <- dynLinkObjs dflags pls objs

        if failed ok_flag then
                return (pls1, Failed)
          else do
742
                pls2 <- dynLinkBCOs dflags pls1 bcos
743
                return (pls2, Succeeded)
744 745 746 747 748 749 750 751


-- 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
752
     in
753
         case (li_uls_obj, li_uls_bco) of
Ian Lynagh's avatar
Ian Lynagh committed
754 755 756
            (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj},
                           li {linkableUnlinked=li_uls_bco}]
            _ -> [li]
757

758
findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
759 760 761 762
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
763
        _    -> pprPanic "findModuleLinkable" (ppr mod)
764 765 766

linkableInSet :: Linkable -> [Linkable] -> Bool
linkableInSet l objs_loaded =
767
  case findModuleLinkable_maybe objs_loaded (linkableModule l) of
768 769
        Nothing -> False
        Just m  -> linkableTime l == linkableTime m
770 771 772 773
\end{code}


%************************************************************************
774
%*                                                                      *
775
\subsection{The object-code linker}
776
%*                                                                      *
777 778 779
%************************************************************************

\begin{code}
780 781 782
dynLinkObjs :: DynFlags -> PersistentLinkerState -> [Linkable]
            -> IO (PersistentLinkerState, SuccessFlag)
dynLinkObjs dflags pls objs = do
783 784 785 786
        -- 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
787 788
            wanted_objs              = map nameOfObject unlinkeds

789
        if dynamicGhc
790 791
            then do dynLoadObjs dflags wanted_objs
                    return (pls1, Succeeded)
792 793 794 795 796 797 798 799 800 801 802 803 804
            else do mapM_ loadObj wanted_objs

                    -- Link them all together
                    ok <- resolveObjs

                    -- If resolving failed, unload all our
                    -- object modules and carry on
                    if succeeded ok then do
                            return (pls1, Succeeded)
                      else do
                            pls2 <- unload_wkr dflags [] pls1
                            return (pls2, Failed)

805 806 807
dynLoadObjs :: DynFlags -> [FilePath] -> IO ()
dynLoadObjs _      []   = return ()
dynLoadObjs dflags objs = do
808 809 810 811 812
    let platform = targetPlatform dflags
    soFile <- newTempName dflags (soExt platform)
    let -- When running TH for a non-dynamic way, we still need to make
        -- -l flags to link against the dynamic libraries, so we turn
        -- Opt_Static off
ian@well-typed.com's avatar
ian@well-typed.com committed
813
        dflags1 = gopt_unset dflags Opt_Static
814
        dflags2 = dflags1 {
815 816 817 818
                      -- We don't want to link the ldInputs in; we'll
                      -- be calling dynLoadObjs with any objects that
                      -- need to be linked.
                      ldInputs = [],
819 820 821 822 823
                      -- Even if we're e.g. profiling, we still want
                      -- the vanilla dynamic libraries, so we set the
                      -- ways / build tag to be just WayDyn.
                      ways = [WayDyn],
                      buildTag = mkBuildTag [WayDyn],
824 825 826 827 828 829
                      outputFile = Just soFile
                  }
    linkDynLib dflags2 objs []
    consIORef (filesToNotIntermediateClean dflags) soFile
    m <- loadDLL soFile
    case m of
830
        Nothing -> return ()
831
        Just err -> panic ("Loading temp shared object failed: " ++ err)
832

833 834 835 836
rmDupLinkables :: [Linkable]    -- Already loaded
               -> [Linkable]    -- New linkables
               -> ([Linkable],  -- New loaded set (including new ones)
                   [Linkable])  -- New linkables (excluding dups)
837 838 839 840 841
rmDupLinkables already ls
  = go already [] ls
  where
    go already extras [] = (already, extras)
    go already extras (l:ls)
842 843
        | linkableInSet l already = go already     extras     ls
        | otherwise               = go (l:already) (l:extras) ls
844 845 846
\end{code}

%************************************************************************
847
%*                                                                      *
848
\subsection{The byte-code linker}
849
%*                                                                      *
850 851 852
%************************************************************************

\begin{code}
853 854 855
dynLinkBCOs :: DynFlags -> PersistentLinkerState -> [Linkable]
            -> IO PersistentLinkerState
dynLinkBCOs dflags pls bcos = do
856

857 858 859 860 861 862 863 864 865 866 867 868
        let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
            pls1                     = pls { bcos_loaded = bcos_loaded' }
            unlinkeds :: [Unlinked]
            unlinkeds                = concatMap linkableUnlinked new_bcos

            cbcs :: [CompiledByteCode]
            cbcs      = map byteCodeOfObject unlinkeds


            ul_bcos    = [b | ByteCode bs _  <- cbcs, b <- bs]
            ies        = [ie | ByteCode _ ie <- cbcs]
            gce       = closure_env pls
869 870
            final_ie  = foldr plusNameEnv (itbl_env pls) ies

871
        (final_gce, _linked_bcos) <- linkSomeBCOs dflags True final_ie gce ul_bcos
872
                -- XXX What happens to these linked_bcos?
873

874 875
        let pls2 = pls1 { closure_env = final_gce,
                          itbl_env    = final_ie }
876

877
        return pls2
878 879

-- Link a bunch of BCOs and return them + updated closure env.
880 881
linkSomeBCOs :: DynFlags
             -> Bool    -- False <=> add _all_ BCOs to returned closure env
882
                        -- True  <=> add only toplevel BCOs to closure env
883 884
             -> ItblEnv
             -> ClosureEnv
885
             -> [UnlinkedBCO]
bjpop@csse.unimelb.edu.au's avatar