Linker.lhs 49.8 KB
Newer Older
1
%
2
% (c) The University of Glasgow 2005-2006
3 4
%
\begin{code}
5 6 7 8 9 10
-- | 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.

11 12 13
{-# OPTIONS -fno-cse #-}
-- -fno-cse is needed for GLOBAL_VAR's to behave properly

mnislaih's avatar
mnislaih committed
14
module Linker ( HValue, getHValue, showLinkerState,
15
                linkExpr, linkDecls, unload, withExtendedLinkEnv,
16
                extendLinkEnv, deleteFromLinkEnv,
17 18
                extendLoadedPkgs,
                linkPackages,initDynLinker,linkModule,
19

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

24
#include "HsVersions.h"
25

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

57
-- Standard libraries
58
import Control.Monad
59

60 61
import Data.IORef
import Data.List
62
import qualified Data.Map as Map
63
import Control.Concurrent.MVar
64

Ian Lynagh's avatar
Ian Lynagh committed
65
import System.FilePath
66
import System.IO
Simon Marlow's avatar
Simon Marlow committed
67 68 69
#if __GLASGOW_HASKELL__ > 704
import System.Directory hiding (findFile)
#else
70
import System.Directory
Simon Marlow's avatar
Simon Marlow committed
71
#endif
72

Ian Lynagh's avatar
Ian Lynagh committed
73
import Distribution.Package hiding (depends, PackageId)
Ian Lynagh's avatar
Ian Lynagh committed
74

75
import Exception
76 77 78 79
\end{code}


%************************************************************************
80 81 82
%*                                                                      *
                        The Linker's state
%*                                                                      *
83 84
%************************************************************************

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

88 89 90
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.
91 92 93 94 95

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

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

99 100 101 102 103 104
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

105 106 107
data PersistentLinkerState
   = PersistentLinkerState {

108
        -- Current global mapping from Names to their true values
109 110
        closure_env :: ClosureEnv,

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

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

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

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

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

  -- Packages that don't need loading, because the compiler
139 140 141 142
  -- 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.
Simon Marlow's avatar
Simon Marlow committed
143
  where init_pkgs = [rtsPackageId]
144

145

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

151 152
extendLinkEnv :: [(Name,HValue)] -> IO ()
-- Automatically discards shadowed bindings
153
extendLinkEnv new_bindings =
154
  modifyPLS_ $ \pls ->
155 156
    let new_closure_env = extendClosureEnv (closure_env pls) new_bindings
    in return pls{ closure_env = new_closure_env }
157

158
deleteFromLinkEnv :: [Name] -> IO ()
159
deleteFromLinkEnv to_remove =
160
  modifyPLS_ $ \pls ->
161 162
    let new_closure_env = delListFromNameEnv (closure_env pls) to_remove
    in return pls{ closure_env = new_closure_env }
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 170
getHValue :: HscEnv -> Name -> IO HValue
getHValue hsc_env name = do
171
  initDynLinker (hsc_dflags hsc_env)
172
  pls <- modifyPLS $ \pls -> do
173 174 175 176 177 178 179
           if (isExternalName name) then do
             (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [nameModule name]
             if (failed ok) then ghcError (ProgramError "")
                            else return (pls', pls')
            else
             return (pls, pls)
  lookupName (closure_env pls) name
180

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

194
   -- Find what packages and linkables are required
195
   (lnks, pkgs) <- getLinkDeps hsc_env hpt pls
196
                               maybe_normal_osuf span needed_mods
197

198
   -- Link the packages and modules required
199 200
   pls1 <- linkPackages' dflags pkgs pls
   linkModules dflags pls1 lnks
201

202

203 204
-- | Temporarily extend the linker state.

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

223 224 225 226
-- 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).
227 228
-- Used to filter both the ClosureEnv and ItblEnv

229
filterNameMap :: [Module] -> NameEnv (Name, a) -> NameEnv (Name, a)
230
filterNameMap mods env
231 232
   = filterNameEnv keep_elt env
   where
233 234
     keep_elt (n,_) = isExternalName n
                      && (nameModule n `elem` mods)
235 236


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

248 249

%************************************************************************
250
%*                                                                      *
251
\subsection{Initialisation}
252
%*                                                                      *
253 254 255
%************************************************************************

\begin{code}
256 257 258 259 260 261 262 263 264 265
-- | 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
266
--     in @ldInputs@,
267 268 269 270 271 272 273
--
--  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.
--
274
initDynLinker :: DynFlags -> IO ()
275
initDynLinker dflags =
276
  modifyPLS_ $ \pls0 -> do
277 278 279 280 281 282 283 284
    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
285
          let pls0 = emptyPLS dflags
286

287 288
          -- (a) initialise the C dynamic linker
        ; initObjLinker
289

290
          -- (b) Load packages from the command-line (Note [preload packages])
291
        ; pls <- linkPackages' dflags (preloadPackages (pkgState dflags)) pls0
292

293 294 295
          -- (c) Link libraries from the command-line
        ; let optl = getOpts dflags opt_l
        ; let minus_ls = [ lib | '-':'l':lib <- optl ]
296 297
        ; let lib_paths = libraryPaths dflags
        ; libspecs <- mapM (locateLib dflags False lib_paths) minus_ls
298

299
          -- (d) Link .o files from the command-line
300
        ; let cmdline_ld_inputs = ldInputs dflags
301

302
        ; classified_ld_inputs <- mapM (classifyLdInput dflags) cmdline_ld_inputs
303

304
          -- (e) Link any MacOS frameworks
305 306 307 308 309 310 311
        ; let platform = targetPlatform dflags
        ; let framework_paths = case platformOS platform of
                                OSDarwin -> frameworkPaths dflags
                                _        -> []
        ; let frameworks = case platformOS platform of
                           OSDarwin -> cmdlineFrameworks dflags
                           _        -> []
312
          -- Finally do (c),(d),(e)
313
        ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ]
314
                               ++ libspecs
315 316 317
                               ++ map Framework frameworks
        ; if null cmdline_lib_specs then return pls
                                    else do
318

319 320 321
        { mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs
        ; maybePutStr dflags "final link ... "
        ; ok <- resolveObjs
322

323 324
        ; if succeeded ok then maybePutStrLn dflags "done"
          else ghcError (ProgramError "linking extra libraries/objects failed")
325 326

        ; return pls
327
        }}
328

329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354

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

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

365 366 367 368 369 370 371
preloadLib :: DynFlags -> [String] -> [String] -> LibrarySpec -> IO ()
preloadLib dflags lib_paths framework_paths lib_spec
  = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
       case lib_spec of
          Object static_ish
             -> do b <- preload_static lib_paths static_ish
                   maybePutStrLn dflags (if b  then "done"
372 373 374 375 376 377 378
                                                else "not found")

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

379
          DLL dll_unadorned
380
             -> do maybe_errstr <- loadDLL (mkSOName platform dll_unadorned)
381 382 383
                   case maybe_errstr of
                      Nothing -> maybePutStrLn dflags "done"
                      Just mm -> preloadFailed mm lib_paths lib_spec
384

385 386
          DLLPath dll_path
             -> do maybe_errstr <- loadDLL dll_path
387 388 389 390
                   case maybe_errstr of
                      Nothing -> maybePutStrLn dflags "done"
                      Just mm -> preloadFailed mm lib_paths lib_spec

391 392 393 394
          Framework framework ->
              case platformOS (targetPlatform dflags) of
              OSDarwin ->
                do maybe_errstr <- loadFramework framework_paths framework
395 396 397
                   case maybe_errstr of
                      Nothing -> maybePutStrLn dflags "done"
                      Just mm -> preloadFailed mm framework_paths lib_spec
398
              _ -> panic "preloadLib Framework"
Ian Lynagh's avatar
Ian Lynagh committed
399

400
  where
401 402
    platform = targetPlatform dflags

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

414
    -- Not interested in the paths in the static case.
Ian Lynagh's avatar
Ian Lynagh committed
415
    preload_static _paths name
416 417 418
       = do b <- doesFileExist name
            if not b then return False
                     else loadObj name >> return True
419 420 421 422
    preload_static_archive _paths name
       = do b <- doesFileExist name
            if not b then return False
                     else loadArchive name >> return True
423 424 425
\end{code}


426
%************************************************************************
427 428 429
%*                                                                      *
                Link a byte-code expression
%*                                                                      *
430 431 432
%************************************************************************

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

446
     -- Take lock for the actual work.
447
   ; modifyPLS $ \pls0 -> do {
448

449
     -- Link the packages and modules required
450
   ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods
451
   ; if failed ok then
452
        ghcError (ProgramError "")
453 454
     else do {

455
     -- Link the expression itself
456
     let ie = itbl_env pls
457
         ce = closure_env pls
458

459
     -- Link the necessary packages and linkables
460
   ; (_, (root_hval:_)) <- linkSomeBCOs dflags False ie ce [root_ul_bco]
461 462
   ; return (pls, root_hval)
   }}}
463
   where
464 465
     free_names = nameSetToList (bcoFreeNames root_ul_bco)

466
     needed_mods :: [Module]
467
     needed_mods = [ nameModule n | n <- free_names,
468 469 470
                     isExternalName n,      -- Names from other modules
                     not (isWiredInName n)  -- Exclude wired-in names
                   ]                        -- (see note below)
471 472 473 474 475
        -- 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
476 477
dieWith :: DynFlags -> SrcSpan -> MsgDoc -> IO a
dieWith dflags span msg = ghcError (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg)))
478 479


480
checkNonStdWay :: DynFlags -> SrcSpan -> IO Bool
481
checkNonStdWay dflags srcspan = do
482
  let tag = buildTag dflags
483
  if null tag {-  || tag == "dyn" -} then return False else do
484 485 486 487 488 489 490 491 492
    -- 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_.
493
  if (objectSuf dflags == normalObjectSuffix)
Ian Lynagh's avatar
Ian Lynagh committed
494
     then failNonStd dflags srcspan
495
     else return True
496

497 498 499
normalObjectSuffix :: String
normalObjectSuffix = phaseInputExt StopLn

Ian Lynagh's avatar
Ian Lynagh committed
500 501
failNonStd :: DynFlags -> SrcSpan -> IO Bool
failNonStd dflags srcspan = dieWith dflags srcspan $
Ian Lynagh's avatar
Ian Lynagh committed
502 503 504
  ptext (sLit "Dynamic linking required, but this is a non-standard build (eg. prof).") $$
  ptext (sLit "You need to build the program twice: once the normal way, and then") $$
  ptext (sLit "in the desired way using -osuf to set the object file suffix.")
505

506

507 508
getLinkDeps :: HscEnv -> HomePackageTable
            -> PersistentLinkerState
509
            -> Bool                             -- replace object suffices?
510 511 512
            -> SrcSpan                          -- for error messages
            -> [Module]                         -- If you need these
            -> IO ([Linkable], [PackageId])     -- ... then link these first
513
-- Fails with an IO exception if it can't find enough files
514

515
getLinkDeps hsc_env hpt pls replace_osuf span mods
516
-- Find all the packages and linkables that a set of modules depends on
517
 = do {
518
        -- 1.  Find the dependent home-pkg-modules/packages from each iface
519 520 521
        -- (omitting iINTERACTIVE, which is already linked)
        (mods_s, pkgs_s) <- follow_deps (filter ((/=) iNTERACTIVE) mods)
                                        emptyUniqSet emptyUniqSet;
522

523 524 525 526 527
        let {
        -- 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 ;
528

529
            linked_mods = map (moduleName.linkableModule)
Simon Marlow's avatar
Simon Marlow committed
530
                                (objs_loaded pls ++ bcos_loaded pls)
531 532 533 534 535
        } ;

        -- 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
536 537
        let { osuf = objectSuf dflags } ;
        lnks_needed <- mapM (get_linkable osuf replace_osuf) mods_needed ;
538

539
        return (lnks_needed, pkgs_needed) }
540
  where
Simon Marlow's avatar
Simon Marlow committed
541 542 543
    dflags = hsc_dflags hsc_env
    this_pkg = thisPackage dflags

Simon Marlow's avatar
Simon Marlow committed
544 545 546 547 548 549 550 551
        -- 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
                -> UniqSet PackageId          -- accum. package dependencies
552
                -> IO ([ModuleName], [PackageId]) -- result
Simon Marlow's avatar
Simon Marlow committed
553
    follow_deps []     acc_mods acc_pkgs
554
        = return (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
Simon Marlow's avatar
Simon Marlow committed
555
    follow_deps (mod:mods) acc_mods acc_pkgs
556 557 558 559
        = do
          mb_iface <- initIfaceCheck hsc_env $
                        loadInterface msg mod (ImportByUser False)
          iface <- case mb_iface of
Ian Lynagh's avatar
Ian Lynagh committed
560
                    Maybes.Failed err      -> ghcError (ProgramError (showSDoc dflags err))
561
                    Maybes.Succeeded iface -> return iface
562 563 564 565 566 567 568 569 570 571 572 573 574 575

          when (mi_boot iface) $ link_boot_mod_error mod

          let
            pkg = modulePackageId mod
            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)
576
            acc_pkgs'  = addListToUniqSet acc_pkgs $ map fst pkg_deps
577 578 579 580 581 582 583 584
          --
          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
585 586


587
    link_boot_mod_error mod =
Ian Lynagh's avatar
Ian Lynagh committed
588
        ghcError (ProgramError (showSDoc dflags (
589
            text "module" <+> ppr mod <+>
Simon Marlow's avatar
Simon Marlow committed
590
            text "cannot be linked; it is only available as a boot module")))
591

592
    no_obj :: Outputable a => a -> IO b
Ian Lynagh's avatar
Ian Lynagh committed
593
    no_obj mod = dieWith dflags span $
594 595 596 597
                     ptext (sLit "cannot find object file for module ") <>
                        quotes (ppr mod) $$
                     while_linking_expr

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

600
        -- This one is a build-system bug
601

602
    get_linkable osuf replace_osuf mod_name      -- A home-package module
603 604 605 606 607 608 609 610 611
        | 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
612 613
        where
            found loc mod = do {
614 615 616 617 618 619
                -- ...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
              }}
620

621 622 623
            adjust_linkable lnk
                | replace_osuf = do
                        new_uls <- mapM adjust_ul (linkableUnlinked lnk)
624
                        return lnk{ linkableUnlinked=new_uls }
625 626 627 628 629 630 631 632
                | otherwise =
                        return lnk

            adjust_ul (DotO file) = do
                MASSERT (osuf `isSuffixOf` file)
                let new_file = reverse (drop (length osuf + 1) (reverse file))
                                 <.> normalObjectSuffix
                ok <- doesFileExist new_file
633
                if (not ok)
Ian Lynagh's avatar
Ian Lynagh committed
634
                   then dieWith dflags span $
635 636 637
                          ptext (sLit "cannot find normal object file ")
                                <> quotes (text new_file) $$ while_linking_expr
                   else return (DotO new_file)
638
            adjust_ul _ = panic "adjust_ul"
639
\end{code}
640

641 642

%************************************************************************
643
%*                                                                      *
644
              Loading a Decls statement
645
%*                                                                      *
646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667
%************************************************************************
\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
      then ghcError (ProgramError "")
      else do

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

    -- Link the necessary packages and linkables
668
    (final_gce, _) <- linkSomeBCOs dflags False ie ce unlinkedBCOs
669 670 671 672 673 674 675
    let pls2 = pls { closure_env = final_gce,
                     itbl_env    = ie }
    return (pls2, ()) --hvals)
  where
    free_names =  concatMap (nameSetToList . bcoFreeNames) unlinkedBCOs

    needed_mods :: [Module]
676
    needed_mods = [ nameModule n | n <- free_names,
677 678 679 680 681 682 683 684 685 686 687
                    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}



688
%************************************************************************
689
%*                                                                      *
690
              Loading a single module
691
%*                                                                      *
692 693
%************************************************************************

694
\begin{code}
695 696 697
linkModule :: HscEnv -> Module -> IO ()
linkModule hsc_env mod = do
  initDynLinker (hsc_dflags hsc_env)
698
  modifyPLS_ $ \pls -> do
699 700
    (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod]
    if (failed ok) then ghcError (ProgramError "could not link module")
701
      else return pls'
702
\end{code}
703 704

%************************************************************************
705 706 707 708 709
%*                                                                      *
                Link some linkables
        The linkables may consist of a mixture of
        byte-code modules and object modules
%*                                                                      *
710 711 712
%************************************************************************

\begin{code}
713 714 715
linkModules :: DynFlags -> PersistentLinkerState -> [Linkable]
            -> IO (PersistentLinkerState, SuccessFlag)
linkModules dflags pls linkables
716
  = mask_ $ do  -- don't want to be interrupted by ^C in here
717 718

        let (objs, bcos) = partition isObjectLinkable
719 720
                              (concatMap partitionLinkable linkables)

721 722 723 724 725 726
                -- 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
727
                pls2 <- dynLinkBCOs dflags pls1 bcos
728
                return (pls2, Succeeded)
729 730 731 732 733 734 735 736


-- 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
737
     in
738
         case (li_uls_obj, li_uls_bco) of
Ian Lynagh's avatar
Ian Lynagh committed
739 740 741
            (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj},
                           li {linkableUnlinked=li_uls_bco}]
            _ -> [li]
742

743
findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
744 745 746 747
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
748
        _    -> pprPanic "findModuleLinkable" (ppr mod)
749 750 751

linkableInSet :: Linkable -> [Linkable] -> Bool
linkableInSet l objs_loaded =
752
  case findModuleLinkable_maybe objs_loaded (linkableModule l) of
753 754
        Nothing -> False
        Just m  -> linkableTime l == linkableTime m
755 756 757 758
\end{code}


%************************************************************************
759
%*                                                                      *
760
\subsection{The object-code linker}
761
%*                                                                      *
762 763 764
%************************************************************************

\begin{code}
765 766 767
dynLinkObjs :: DynFlags -> PersistentLinkerState -> [Linkable]
            -> IO (PersistentLinkerState, SuccessFlag)
dynLinkObjs dflags pls objs = do
768 769 770 771 772 773 774
        -- 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

        mapM_ loadObj (map nameOfObject unlinkeds)

Gabor Greif's avatar
typo  
Gabor Greif committed
775
        -- Link them all together
776 777 778 779 780 781 782 783
        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
784
                return (pls2, Failed)
785 786


787 788 789 790
rmDupLinkables :: [Linkable]    -- Already loaded
               -> [Linkable]    -- New linkables
               -> ([Linkable],  -- New loaded set (including new ones)
                   [Linkable])  -- New linkables (excluding dups)
791 792 793 794 795
rmDupLinkables already ls
  = go already [] ls
  where
    go already extras [] = (already, extras)
    go already extras (l:ls)
796 797
        | linkableInSet l already = go already     extras     ls
        | otherwise               = go (l:already) (l:extras) ls
798 799 800
\end{code}

%************************************************************************
801
%*                                                                      *
802
\subsection{The byte-code linker}
803
%*                                                                      *
804 805 806
%************************************************************************

\begin{code}
807 808 809
dynLinkBCOs :: DynFlags -> PersistentLinkerState -> [Linkable]
            -> IO PersistentLinkerState
dynLinkBCOs dflags pls bcos = do
810

811 812 813 814 815 816 817 818 819 820 821 822
        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
823 824
            final_ie  = foldr plusNameEnv (itbl_env pls) ies

825
        (final_gce, _linked_bcos) <- linkSomeBCOs dflags True final_ie gce ul_bcos
826
                -- XXX What happens to these linked_bcos?
827

828 829
        let pls2 = pls1 { closure_env = final_gce,
                          itbl_env    = final_ie }
830

831
        return pls2
832 833

-- Link a bunch of BCOs and return them + updated closure env.
834 835
linkSomeBCOs :: DynFlags
             -> Bool    -- False <=> add _all_ BCOs to returned closure env
836
                        -- True  <=> add only toplevel BCOs to closure env
837 838
             -> ItblEnv
             -> ClosureEnv
839
             -> [UnlinkedBCO]
840
             -> IO (ClosureEnv, [HValue])
841 842 843 844
                        -- The returned HValues are associated 1-1 with
                        -- the incoming unlinked BCOs.  Each gives the
                        -- value of the corresponding unlinked BCO

845
linkSomeBCOs dflags toplevs_only ie ce_in ul_bcos
846
   = do let nms = map unlinkedBCOName ul_bcos
847
        hvals <- fixIO
848
                    ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
849
                               in  mapM (linkBCO dflags ie ce_out) ul_bcos )
850 851
        let ce_all_additions = zip nms hvals
            ce_top_additions = filter (isExternalName.fst) ce_all_additions
852
            ce_additions     = if toplevs_only then ce_top_additions
853
                                               else ce_all_additions
854 855 856 857
            ce_out = -- make sure we're not inserting duplicate names into the
                     -- closure environment, which leads to trouble.
                     ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions))
                     extendClosureEnv ce_in ce_additions
858
        return (ce_out, hvals)
859

860 861 862 863
\end{code}


%************************************************************************
864 865 866
%*                                                                      *
                Unload some object modules
%*                                                                      *
867 868 869
%************************************************************************

\begin{code}
sof's avatar
sof committed
870
-- ---------------------------------------------------------------------------
871
-- | Unloading old objects ready for a new compilation sweep.
872 873
--
-- The compilation manager provides us with a list of linkables that it
874
-- considers \"stable\", i.e. won't be recompiled this time around.  For
875 876
-- each of the modules current linked in memory,
--
877 878
--   * if the linkable is stable (and it's the same one -- the user may have
--     recompiled the module on the side), we keep it,
879
--
880
--   * otherwise, we unload it.
881
--
882 883 884 885 886
--   * we also implicitly unload all temporary bindings at this point.
--
unload :: DynFlags
       -> [Linkable] -- ^ The linkables to *keep*.
       -> IO ()
887
unload dflags linkables
888
  = mask_ $ do -- mask, so we're safe from Ctrl-C in here
sof's avatar
sof committed
889

890 891 892 893
        -- Initialise the linker (if it's not been done already)
        initDynLinker dflags

        new_pls
894
            <- modifyPLS $ \pls -> do
895
                 pls1 <- unload_wkr dflags linkables pls
896
                 return (pls1, pls1)
897

898 899 900
        debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls))
        debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls))
        return ()
901

902
unload_wkr :: DynFlags
903 904
           -> [Linkable]                -- stable linkables
           -> PersistentLinkerState
905 906 907
           -> IO PersistentLinkerState
-- Does the core unload business
-- (the wrapper blocks exceptions and deals with the PLS get and put)
908

Ian Lynagh's avatar
Ian Lynagh committed
909
unload_wkr _ linkables pls
910
  = do  let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
911

912
        objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls)
913 914
        bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)

915 916
        let bcos_retained = map linkableModule bcos_loaded'
            itbl_env'     = filterNameMap bcos_retained (itbl_env pls)
917
            closure_env'  = filterNameMap bcos_retained (closure_env pls)
918 919 920 921
            new_pls = pls { itbl_env = itbl_env',
                            closure_env = closure_env',
                            bcos_loaded = bcos_loaded',
                            objs_loaded = objs_loaded' }
922

923
        return new_pls
924 925 926
  where
    maybeUnload :: [Linkable] -> Linkable -> IO Bool
    maybeUnload keep_linkables lnk
927
      | linkableInSet lnk keep_linkables = return True
928
      | otherwise
929
      = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk]
930 931 932 933 934 935 936
                -- The components of a BCO linkable may contain
                -- dot-o files.  Which is very confusing.
                --
                -- But the BCO parts can be unlinked just by
                -- letting go of them (plus of course depopulating
                -- the symbol table which is done in the main body)
           return False
937 938 939 940
\end{code}


%************************************************************************
941 942 943
%*                                                                      *
                Loading packages
%*                                                                      *
944 945 946 947
%************************************************************************


\begin{code}
948 949 950 951 952
data LibrarySpec
   = Object FilePath    -- Full path name of a .o file, including trailing .o
                        -- For dynamic objects only, try to find the object
                        -- file in all the directories specified in
                        -- v_Library_paths before giving up.
953

954
   | Archive FilePath   -- Full path name of a .a file, including trailing .a