Linker.hs 53.3 KB
Newer Older
1 2
{-# LANGUAGE CPP, NondecreasingIndentation #-}
{-# 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
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 Platform
54
import SysTools
55

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

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

Ian Lynagh's avatar
Ian Lynagh committed
65
import System.FilePath
66
import System.IO
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 151
extendLinkEnv :: [(Name,HValue)] -> IO ()
-- Automatically discards shadowed bindings
152
extendLinkEnv new_bindings =
153
  modifyPLS_ $ \pls ->
154 155
    let new_closure_env = extendClosureEnv (closure_env pls) new_bindings
    in return pls{ closure_env = new_closure_env }
156

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

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

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

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

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

201

202 203
-- | Temporarily extend the linker state.

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

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

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


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

246

247 248 249 250 251
{- **********************************************************************

                        Initialisation

  ********************************************************************* -}
252

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

284 285
          -- (a) initialise the C dynamic linker
        ; initObjLinker
286

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

290 291 292 293 294 295 296 297 298 299 300 301 302
          -- steps (c), (d) and (e)
        ; linkCmdLineLibs' dflags pls
        }

linkCmdLineLibs :: DynFlags -> IO ()
linkCmdLineLibs dflags = do
  initDynLinker dflags
  modifyPLS_ $ \pls -> do
    linkCmdLineLibs' dflags pls

linkCmdLineLibs' :: DynFlags -> PersistentLinkerState -> IO PersistentLinkerState
linkCmdLineLibs' dflags@(DynFlags { ldInputs     = cmdline_ld_inputs
                                  , libraryPaths = lib_paths}) pls =
303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343
  do  -- (c) Link libraries from the command-line
      let minus_ls = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ]
      libspecs <- mapM (locateLib dflags False lib_paths) minus_ls

      -- (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
      pathCache <- mapM addLibrarySearchPath all_paths

      pls1 <- foldM (preloadLib dflags lib_paths framework_paths) pls
                    cmdline_lib_specs
      maybePutStr dflags "final link ... "
      ok <- resolveObjs

      -- DLLs are loaded, reset the search paths
      mapM_ removeLibrarySearchPath $ reverse pathCache

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

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

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

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

380
preloadLib :: DynFlags -> [String] -> [String] -> PersistentLinkerState
381
           -> LibrarySpec -> IO PersistentLinkerState
382
preloadLib dflags lib_paths framework_paths pls lib_spec
383 384 385
  = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
       case lib_spec of
          Object static_ish
386
             -> do (b, pls1) <- preload_static lib_paths static_ish
387
                   maybePutStrLn dflags (if b  then "done"
388
                                                else "not found")
389
                   return pls1
390 391 392 393 394

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

397
          DLL dll_unadorned
398
             -> do maybe_errstr <- loadDLL (mkSOName platform dll_unadorned)
399 400
                   case maybe_errstr of
                      Nothing -> maybePutStrLn dflags "done"
Austin Seipp's avatar
Austin Seipp committed
401 402 403 404 405 406 407 408 409 410
                      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
411
                   return pls
412

413 414
          DLLPath dll_path
             -> do maybe_errstr <- loadDLL dll_path
415 416 417
                   case maybe_errstr of
                      Nothing -> maybePutStrLn dflags "done"
                      Just mm -> preloadFailed mm lib_paths lib_spec
418
                   return pls
419

420
          Framework framework ->
421 422 423 424 425
              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
426
                      return pls
427
              else panic "preloadLib Framework"
Ian Lynagh's avatar
Ian Lynagh committed
428

429
  where
430 431
    platform = targetPlatform dflags

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

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

453 454 455
    preload_static_archive _paths name
       = do b <- doesFileExist name
            if not b then return False
456
                     else do if dynamicGhc
457 458 459
                                 then panic "Loading archives not supported"
                                 else loadArchive name
                             return True
460 461


462 463 464 465 466
{- **********************************************************************

                        Link a byte-code expression

  ********************************************************************* -}
467

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

481
     -- Take lock for the actual work.
482
   ; modifyPLS $ \pls0 -> do {
483

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

490
     -- Link the expression itself
491
     let ie = itbl_env pls
492
         ce = closure_env pls
493

494
     -- Link the necessary packages and linkables
495
   ; (_, (root_hval:_)) <- linkSomeBCOs dflags False ie ce [root_ul_bco]
496 497
   ; return (pls, root_hval)
   }}}
498
   where
499
     free_names = nameSetElems (bcoFreeNames root_ul_bco)
500

501
     needed_mods :: [Module]
502
     needed_mods = [ nameModule n | n <- free_names,
503 504 505
                     isExternalName n,      -- Names from other modules
                     not (isWiredInName n)  -- Exclude wired-in names
                   ]                        -- (see note below)
506 507 508 509 510
        -- 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
511
dieWith :: DynFlags -> SrcSpan -> MsgDoc -> IO a
512
dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg)))
513 514


515
checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
516 517 518 519 520 521 522 523 524 525 526 527 528 529
checkNonStdWay dflags srcspan
  | 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 ++ "_"
530

531 532 533
normalObjectSuffix :: String
normalObjectSuffix = phaseInputExt StopLn

534
failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
Ian Lynagh's avatar
Ian Lynagh committed
535
failNonStd dflags srcspan = dieWith dflags srcspan $
Ian Lynagh's avatar
Ian Lynagh committed
536
  ptext (sLit "Dynamic linking required, but this is a non-standard build (eg. prof).") $$
537 538
  ptext (sLit "You need to build the program twice: once") <+>
  ghciWay <> ptext (sLit ", and then") $$
Ian Lynagh's avatar
Ian Lynagh committed
539
  ptext (sLit "in the desired way using -osuf to set the object file suffix.")
540 541 542 543
    where ghciWay
            | dynamicGhc = ptext (sLit "with -dynamic")
            | rtsIsProfiled = ptext (sLit "with -prof")
            | otherwise = ptext (sLit "the normal way")
544

545 546
getLinkDeps :: HscEnv -> HomePackageTable
            -> PersistentLinkerState
547
            -> Maybe FilePath                   -- replace object suffices?
548 549
            -> SrcSpan                          -- for error messages
            -> [Module]                         -- If you need these
550
            -> IO ([Linkable], [UnitId])     -- ... then link these first
551
-- Fails with an IO exception if it can't find enough files
552

553
getLinkDeps hsc_env hpt pls replace_osuf span mods
554
-- Find all the packages and linkables that a set of modules depends on
555
 = do {
556
        -- 1.  Find the dependent home-pkg-modules/packages from each iface
557 558
        -- (omitting modules from the interactive package, which is already linked)
      ; (mods_s, pkgs_s) <- follow_deps (filterOut isInteractiveModule mods)
559
                                        emptyUniqSet emptyUniqSet;
560

561
      ; let {
562 563 564 565
        -- 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 ;
566

567
            linked_mods = map (moduleName.linkableModule)
568
                                (objs_loaded pls ++ bcos_loaded pls)  }
569 570 571

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

576
      ; return (lnks_needed, pkgs_needed) }
577
  where
Simon Marlow's avatar
Simon Marlow committed
578 579 580
    dflags = hsc_dflags hsc_env
    this_pkg = thisPackage dflags

581 582 583 584 585 586 587
        -- 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
588 589
                -> UniqSet UnitId          -- accum. package dependencies
                -> IO ([ModuleName], [UnitId]) -- result
Simon Marlow's avatar
Simon Marlow committed
590
    follow_deps []     acc_mods acc_pkgs
591
        = return (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
Simon Marlow's avatar
Simon Marlow committed
592
    follow_deps (mod:mods) acc_mods acc_pkgs
593 594 595 596
        = do
          mb_iface <- initIfaceCheck hsc_env $
                        loadInterface msg mod (ImportByUser False)
          iface <- case mb_iface of
597
                    Maybes.Failed err      -> throwGhcExceptionIO (ProgramError (showSDoc dflags err))
598
                    Maybes.Succeeded iface -> return iface
599 600 601 602

          when (mi_boot iface) $ link_boot_mod_error mod

          let
603
            pkg = moduleUnitId mod
604 605 606 607 608 609 610 611 612
            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)
613
            acc_pkgs'  = addListToUniqSet acc_pkgs $ map fst pkg_deps
614 615 616 617 618 619 620 621
          --
          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
622 623


624
    link_boot_mod_error mod =
625
        throwGhcExceptionIO (ProgramError (showSDoc dflags (
626
            text "module" <+> ppr mod <+>
Simon Marlow's avatar
Simon Marlow committed
627
            text "cannot be linked; it is only available as a boot module")))
628

629
    no_obj :: Outputable a => a -> IO b
Ian Lynagh's avatar
Ian Lynagh committed
630
    no_obj mod = dieWith dflags span $
631 632 633 634
                     ptext (sLit "cannot find object file for module ") <>
                        quotes (ppr mod) $$
                     while_linking_expr

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

637
        -- This one is a build-system bug
638

639
    get_linkable osuf mod_name      -- A home-package module
640
        | Just mod_info <- lookupUFM hpt mod_name
641
        = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))
642 643 644 645 646
        | 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
647
                  Found loc mod -> found loc mod
648
                  _ -> no_obj mod_name
649 650
        where
            found loc mod = do {
651 652 653 654
                -- ...and then find the linkable for it
               mb_lnk <- findObjectLinkableMaybe mod loc ;
               case mb_lnk of {
                  Nothing  -> no_obj mod ;
655
                  Just lnk -> adjust_linkable lnk
656
              }}
657

658
            adjust_linkable lnk
659 660 661
                | Just new_osuf <- replace_osuf = do
                        new_uls <- mapM (adjust_ul new_osuf)
                                        (linkableUnlinked lnk)
662
                        return lnk{ linkableUnlinked=new_uls }
663
                | otherwise =
664
                        return lnk
665

666
            adjust_ul new_osuf (DotO file) = do
667
                MASSERT(osuf `isSuffixOf` file)
668
                let file_base = dropTail (length osuf + 1) file
669 670 671 672
                    new_file = file_base <.> new_osuf
                ok <- doesFileExist new_file
                if (not ok)
                   then dieWith dflags span $
673
                          ptext (sLit "cannot find object file ")
674 675 676 677 678
                                <> 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
679

680

681 682
{- **********************************************************************

683
              Loading a Decls statement
684 685 686

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

687 688 689 690 691 692 693 694 695 696 697 698
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
699
      then throwGhcExceptionIO (ProgramError "")
700 701 702 703 704 705 706
      else do

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

    -- Link the necessary packages and linkables
707
    (final_gce, _) <- linkSomeBCOs dflags False ie ce unlinkedBCOs
708 709 710 711
    let pls2 = pls { closure_env = final_gce,
                     itbl_env    = ie }
    return (pls2, ()) --hvals)
  where
712
    free_names =  concatMap (nameSetElems . bcoFreeNames) unlinkedBCOs
713 714

    needed_mods :: [Module]
715
    needed_mods = [ nameModule n | n <- free_names,
716 717 718 719 720 721 722 723 724 725
                    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.



726 727
{- **********************************************************************

728 729
              Loading a single module

730 731
  ********************************************************************* -}

732 733 734
linkModule :: HscEnv -> Module -> IO ()
linkModule hsc_env mod = do
  initDynLinker (hsc_dflags hsc_env)
735
  modifyPLS_ $ \pls -> do
736
    (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod]
737
    if (failed ok) then throwGhcExceptionIO (ProgramError "could not link module")
738
      else return pls'
739

740 741
{- **********************************************************************

742 743 744
                Link some linkables
        The linkables may consist of a mixture of
        byte-code modules and object modules
745

746 747
  ********************************************************************* -}

748 749 750
linkModules :: DynFlags -> PersistentLinkerState -> [Linkable]
            -> IO (PersistentLinkerState, SuccessFlag)
linkModules dflags pls linkables
751
  = mask_ $ do  -- don't want to be interrupted by ^C in here
752 753

        let (objs, bcos) = partition isObjectLinkable
754 755
                              (concatMap partitionLinkable linkables)

756 757 758 759 760 761
                -- 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
762
                pls2 <- dynLinkBCOs dflags pls1 bcos
763
                return (pls2, Succeeded)
764 765 766 767 768 769 770 771


-- 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
772
     in
773
         case (li_uls_obj, li_uls_bco) of
Ian Lynagh's avatar
Ian Lynagh committed
774 775 776
            (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj},
                           li {linkableUnlinked=li_uls_bco}]
            _ -> [li]
777

778
findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
779 780 781 782
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
783
        _    -> pprPanic "findModuleLinkable" (ppr mod)
784 785 786

linkableInSet :: Linkable -> [Linkable] -> Bool
linkableInSet l objs_loaded =
787
  case findModuleLinkable_maybe objs_loaded (linkableModule l) of
788 789
        Nothing -> False
        Just m  -> linkableTime l == linkableTime m
790 791


792 793 794 795 796
{- **********************************************************************

                The object-code linker

  ********************************************************************* -}
797

798 799 800
dynLinkObjs :: DynFlags -> PersistentLinkerState -> [Linkable]
            -> IO (PersistentLinkerState, SuccessFlag)
dynLinkObjs dflags pls objs = do
801 802 803 804
        -- 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
805 806
            wanted_objs              = map nameOfObject unlinkeds

807
        if dynamicGhc
808 809
            then do pls2 <- dynLoadObjs dflags pls1 wanted_objs
                    return (pls2, Succeeded)
810 811 812 813 814 815 816 817 818 819 820 821 822
            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)

823 824 825 826 827

dynLoadObjs :: DynFlags -> PersistentLinkerState -> [FilePath]
            -> IO PersistentLinkerState
dynLoadObjs _      pls []   = return pls
dynLoadObjs dflags pls objs = do
828
    let platform = targetPlatform dflags
829
    (soFile, libPath , libName) <- newTempLibName dflags (soExt platform)
830 831 832
    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
833
        dflags1 = gopt_unset dflags Opt_Static
834
        dflags2 = dflags1 {
835 836
                      -- We don't want the original ldInputs in
                      -- (they're already linked in), but we do want
837 838
                      -- to link against previous dynLoadObjs
                      -- libraries if there were any, so that the linker
839 840 841
                      -- can resolve dependencies when it loads this
                      -- library.
                      ldInputs =
842 843
                        concatMap
                            (\(lp, l) ->
844 845 846
                                 [ Option ("-L" ++ lp)
                                 , Option ("-Wl,-rpath")
                                 , Option ("-Wl," ++ lp)
847
                                 , Option ("-l" ++  l)
848 849
                                 ])
                            (temp_sos pls),
850 851 852 853 854
                      -- 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],
855 856
                      outputFile = Just soFile
                  }
857 858 859 860
    -- link all "loaded packages" so symbols in those can be resolved
    -- Note: We are loading packages with local scope, so to see the
    -- symbols in this link we must link all loaded packages again.
    linkDynLib dflags2 objs (pkgs_loaded pls)
861 862 863
    consIORef (filesToNotIntermediateClean dflags) soFile
    m <- loadDLL soFile
    case m of
864
        Nothing -> return pls { temp_sos = (libPath, libName) : temp_sos pls }
865
        Just err -> panic ("Loading temp shared object failed: " ++ err)
866

867 868 869 870
rmDupLinkables :: [Linkable]    -- Already loaded
               -> [Linkable]    -- New linkables
               -> ([Linkable],  -- New loaded set (including new ones)
                   [Linkable])  -- New linkables (excluding dups)
871 872 873 874 875
rmDupLinkables already ls
  = go already [] ls
  where
    go already extras [] = (already, extras)
    go already extras (l:ls)
876 877
        | linkableInSet l already = go already     extras     ls
        | otherwise               = go (l:already) (l:extras) ls
878

879 880 881 882 883 884
{- **********************************************************************

                The byte-code linker

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

885

886 887 888
dynLinkBCOs :: DynFlags -> PersistentLinkerState -> [Linkable]
            -> IO PersistentLinkerState
dynLinkBCOs dflags pls bcos = do
889

890 891 892 893 894 895 896 897 898 899 900 901
        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
902 903
            final_ie  = foldr plusNameEnv (itbl_env pls) ies

904
        (final_gce, _linked_bcos) <- linkSomeBCOs dflags True final_ie gce ul_bcos
905
                -- XXX What happens to these linked_bcos?
906

907 908
        let pls2 = pls1 { closure_env = final_gce,
                          itbl_env    = final_ie }
909

910
        return pls2
911 912

-- Link a bunch of BCOs and return them + updated closure env.
913 914
linkSomeBCOs :: DynFlags
             -> Bool    -- False <=> add _all_ BCOs to returned closure env
915
                        -- True  <=> add only toplevel BCOs to closure env
916 917
             -> ItblEnv
             -> ClosureEnv
918
             -> [UnlinkedBCO]
919
             -> IO (ClosureEnv, [HValue])
920 921 922 923
                        -- The returned HValues are associated 1-1 with
                        -- the incoming unlinked BCOs.  Each gives the
                        -- value of the corresponding unlinked BCO

924
linkSomeBCOs dflags toplevs_only ie ce_in ul_bcos
925
   = do let nms = map unlinkedBCOName ul_bcos
926
        hvals <- fixIO
927
                    ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
928
                               in  mapM (linkBCO dflags ie ce_out) ul_bcos )
929 930
        let ce_all_additions = zip nms hvals
            ce_top_additions = filter (isExternalName.fst) ce_all_additions
931
            ce_additions     = if toplevs_only then ce_top_additions
932
                                               else ce_all_additions
933 934
            ce_out = -- make sure we're not inserting duplicate names into the
                     -- closure environment, which leads to trouble.
935
                     ASSERT(all (not . (`elemNameEnv` ce_in)) (map fst ce_additions))
936
                     extendClosureEnv ce_in ce_additions
937
        return (ce_out, hvals)
938

939

940
{- **********************************************************************
941

942
                Unload some object modules
943

944 945
  ********************************************************************* -}

sof's avatar
sof committed
946
-- ---------------------------------------------------------------------------
947
-- | Unloading old objects ready for a new compilation sweep.
948 949
--
-- The compilation manager provides us with a list of linkables that it
950
-- considers \"stable\", i.e. won't be recompiled this time around.  For
951 952
-- each of the modules current linked in memory,
--
953 954
--   * if the linkable is stable (and it's the same one -- the user may have
--     recompiled the module on the side), we keep it,
955
--
956
--   * otherwise, we unload it.
957
--
958 959 960 961 962
--   * we also implicitly unload all temporary bindings at this point.
--
unload :: DynFlags
       -> [Linkable] -- ^ The linkables to *keep*.
       -> IO ()
963
unload dflags linkables
964
  = mask_ $ do -- mask, so we're safe from Ctrl-C in here
sof's avatar
sof committed
965

966 967 968 969
        -- Initialise the linker (if it's not been done already)
        initDynLinker dflags

        new_pls
970
            <- modifyPLS $ \pls -> do
971
                 pls1 <- unload_wkr dflags linkables pls
972
                 return (pls1, pls1)
973

974 975 976
        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 ()
977