Linker.hs 66.4 KB
Newer Older
1
{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections, RecordWildCards #-}
Simon Marlow's avatar
Simon Marlow committed
2
{-# LANGUAGE BangPatterns #-}
3
{-# OPTIONS_GHC -fno-cse #-}
4 5
-- -fno-cse is needed for GLOBAL_VAR's to behave properly

6 7 8
--
--  (c) The University of Glasgow 2002-2006
--
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
                extendLoadedPkgs,
18 19 20
                linkPackages, initDynLinker, linkModule,
                linkCmdLineLibs,
                uninitializedLinker
21
        ) where
sof's avatar
sof committed
22

23
#include "HsVersions.h"
24

25 26
import GhcPrelude

27 28
import GHCi
import GHCi.RemoteTypes
29
import LoadIface
30 31
import ByteCodeLink
import ByteCodeAsm
32
import ByteCodeTypes
33
import TcRnMonad
34
import Packages
35 36
import DriverPhases
import Finder
37
import HscTypes
38
import Name
39
import NameEnv
40
import Module
41
import ListSetOps
42
import LinkerTypes (DynLinker(..), LinkerUnitId, PersistentLinkerState(..))
43 44
import DynFlags
import BasicTypes
45
import Outputable
46 47 48 49
import Panic
import Util
import ErrUtils
import SrcLoc
50
import qualified Maybes
51
import UniqDSet
52
import FastString
John Ericson's avatar
John Ericson committed
53
import GHC.Platform
54
import SysTools
duog's avatar
duog committed
55
import FileCleanup
56

57
-- Standard libraries
58
import Control.Monad
59

60
import Data.Char (isSpace)
61 62
import Data.IORef
import Data.List
63
import Data.Maybe
64
import Control.Concurrent.MVar
65

Ian Lynagh's avatar
Ian Lynagh committed
66
import System.FilePath
67
import System.Directory
68
import System.IO.Unsafe
69
import System.Environment (lookupEnv)
70 71 72 73

#if defined(mingw32_HOST_OS)
import System.Win32.Info (getSystemDirectory)
#endif
74

75
import Exception
76

77 78
{- **********************************************************************

79
                        The Linker's state
80

81 82 83
  ********************************************************************* -}

{-
84
The persistent linker state *must* match the actual state of the
85
C dynamic linker at all times.
86

87 88 89 90
The MVar used to hold the PersistentLinkerState contains a Maybe
PersistentLinkerState. The MVar serves to ensure mutual exclusion between
multiple loaded copies of the GHC library. The Maybe may be Nothing to
indicate that the linker has not yet been initialised.
91 92 93

The PersistentLinkerState maps Names to actual closures (for
interpreted code only), for use during linking.
94
-}
95 96 97 98

uninitializedLinker :: IO DynLinker
uninitializedLinker =
  newMVar Nothing >>= (pure . DynLinker)
99

Moritz Angermann's avatar
Moritz Angermann committed
100 101 102
uninitialised :: a
uninitialised = panic "Dynamic linker not initialised"

103 104 105
modifyPLS_ :: DynLinker -> (PersistentLinkerState -> IO PersistentLinkerState) -> IO ()
modifyPLS_ dl f =
  modifyMVar_ (dl_mpls dl) (fmap pure . f . fromMaybe uninitialised)
106

107 108 109
modifyPLS :: DynLinker -> (PersistentLinkerState -> IO (PersistentLinkerState, a)) -> IO a
modifyPLS dl f =
  modifyMVar (dl_mpls dl) (fmapFst pure . f . fromMaybe uninitialised)
Moritz Angermann's avatar
Moritz Angermann committed
110 111
  where fmapFst f = fmap (\(x, y) -> (f x, y))

112 113 114
readPLS :: DynLinker -> IO PersistentLinkerState
readPLS dl =
  (fmap (fromMaybe uninitialised) . readMVar) (dl_mpls dl)
Moritz Angermann's avatar
Moritz Angermann committed
115 116

modifyMbPLS_
117
  :: DynLinker -> (Maybe PersistentLinkerState -> IO (Maybe PersistentLinkerState)) -> IO ()
118
modifyMbPLS_ dl f = modifyMVar_ (dl_mpls dl) f
119

120
emptyPLS :: DynFlags -> PersistentLinkerState
121 122 123 124 125
emptyPLS _ = PersistentLinkerState {
                        closure_env = emptyNameEnv,
                        itbl_env    = emptyNameEnv,
                        pkgs_loaded = init_pkgs,
                        bcos_loaded = [],
126
                        objs_loaded = [],
127
                        temp_sos = [] }
128 129

  -- Packages that don't need loading, because the compiler
130 131 132 133
  -- 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.
134
  where init_pkgs = map toInstalledUnitId [rtsUnitId]
135

136 137 138
extendLoadedPkgs :: DynLinker -> [InstalledUnitId] -> IO ()
extendLoadedPkgs dl pkgs =
  modifyPLS_ dl $ \s ->
139
      return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }
140

141 142 143
extendLinkEnv :: DynLinker -> [(Name,ForeignHValue)] -> IO ()
extendLinkEnv dl new_bindings =
  modifyPLS_ dl $ \pls@PersistentLinkerState{..} -> do
Simon Marlow's avatar
Simon Marlow committed
144 145 146
    let new_ce = extendClosureEnv closure_env new_bindings
    return $! pls{ closure_env = new_ce }
    -- strictness is important for not retaining old copies of the pls
147

148 149 150
deleteFromLinkEnv :: DynLinker -> [Name] -> IO ()
deleteFromLinkEnv dl to_remove =
  modifyPLS_ dl $ \pls -> do
151 152 153
    let ce = closure_env pls
    let new_ce = delListFromNameEnv ce to_remove
    return pls{ closure_env = new_ce }
154

155 156 157 158 159
-- | 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.
160
getHValue :: HscEnv -> Name -> IO ForeignHValue
161
getHValue hsc_env name = do
162
  let dl = hsc_dynLinker hsc_env
163
  initDynLinker hsc_env
164
  pls <- modifyPLS dl $ \pls -> do
165
           if (isExternalName name) then do
166 167
             (pls', ok) <- linkDependencies hsc_env pls noSrcSpan
                              [nameModule name]
168
             if (failed ok) then throwGhcExceptionIO (ProgramError "")
169 170 171
                            else return (pls', pls')
            else
             return (pls, pls)
172 173 174 175 176 177 178 179 180 181
  case lookupNameEnv (closure_env pls) name of
    Just (_,aa) -> return aa
    Nothing
        -> ASSERT2(isExternalName name, ppr name)
           do let sym_to_find = nameToCLabel name "closure"
              m <- lookupClosure hsc_env (unpackFS sym_to_find)
              case m of
                Just hvref -> mkFinalizedHValue hsc_env hvref
                Nothing -> linkFail "ByteCodeLink.lookupCE"
                             (unpackFS sym_to_find)
182

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

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

200
   -- Link the packages and modules required
201 202
   pls1 <- linkPackages' hsc_env pkgs pls
   linkModules hsc_env pls1 lnks
203

204

205 206
-- | Temporarily extend the linker state.

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

225

226
-- | Display the persistent linker state.
227 228 229
showLinkerState :: DynLinker -> DynFlags -> IO ()
showLinkerState dl dflags
  = do pls <- readPLS dl
Ben Gamari's avatar
Ben Gamari committed
230
       putLogMsg dflags NoReason SevDump noSrcSpan
Sylvain Henry's avatar
Sylvain Henry committed
231
          (defaultDumpStyle dflags)
232
                 (vcat [text "----- Linker state -----",
233 234 235
                        text "Pkgs:" <+> ppr (pkgs_loaded pls),
                        text "Objs:" <+> ppr (objs_loaded pls),
                        text "BCOs:" <+> ppr (bcos_loaded pls)])
236

237

238 239 240 241 242
{- **********************************************************************

                        Initialisation

  ********************************************************************* -}
243

244 245 246 247 248 249 250 251 252 253
-- | 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
254
--     in @ldInputs@,
255 256 257 258 259 260 261
--
--  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.
--
262
initDynLinker :: HscEnv -> IO ()
263 264 265
initDynLinker hsc_env = do
  let dl = hsc_dynLinker hsc_env
  modifyMbPLS_ dl $ \pls -> do
Moritz Angermann's avatar
Moritz Angermann committed
266 267 268
    case pls of
      Just  _ -> return pls
      Nothing -> Just <$> reallyInitDynLinker hsc_env
269

270 271 272 273 274
reallyInitDynLinker :: HscEnv -> IO PersistentLinkerState
reallyInitDynLinker hsc_env = do
  -- Initialise the linker state
  let dflags = hsc_dflags hsc_env
      pls0 = emptyPLS dflags
275

276 277
  -- (a) initialise the C dynamic linker
  initObjLinker hsc_env
278

279 280
  -- (b) Load packages from the command-line (Note [preload packages])
  pls <- linkPackages' hsc_env (preloadPackages (pkgState dflags)) pls0
281

282 283
  -- steps (c), (d) and (e)
  linkCmdLineLibs' hsc_env pls
284

285 286 287

linkCmdLineLibs :: HscEnv -> IO ()
linkCmdLineLibs hsc_env = do
288
  let dl = hsc_dynLinker hsc_env
289
  initDynLinker hsc_env
290
  modifyPLS_ dl $ \pls -> do
291 292 293 294 295 296
    linkCmdLineLibs' hsc_env pls

linkCmdLineLibs' :: HscEnv -> PersistentLinkerState -> IO PersistentLinkerState
linkCmdLineLibs' hsc_env pls =
  do
      let dflags@(DynFlags { ldInputs = cmdline_ld_inputs
297 298
                           , libraryPaths = lib_paths_base})
            = hsc_dflags hsc_env
299

300
      -- (c) Link libraries from the command-line
301 302 303 304 305 306
      let minus_ls_1 = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ]

      -- On Windows we want to add libpthread by default just as GCC would.
      -- However because we don't know the actual name of pthread's dll we
      -- need to defer this to the locateLib call so we can't initialize it
      -- inside of the rts. Instead we do it here to be able to find the
307
      -- import library for pthreads. See #13210.
308 309 310 311 312
      let platform = targetPlatform dflags
          os       = platformOS platform
          minus_ls = case os of
                       OSMinGW32 -> "pthread" : minus_ls_1
                       _         -> minus_ls_1
313 314
      -- See Note [Fork/Exec Windows]
      gcc_paths <- getGCCPaths dflags os
315

316 317
      lib_paths_env <- addEnvPaths "LIBRARY_PATH" lib_paths_base

318
      maybePutStrLn dflags "Search directories (user):"
319
      maybePutStr dflags (unlines $ map ("  "++) lib_paths_env)
320 321 322
      maybePutStrLn dflags "Search directories (gcc):"
      maybePutStr dflags (unlines $ map ("  "++) gcc_paths)

323
      libspecs
324
        <- mapM (locateLib hsc_env False lib_paths_env gcc_paths) minus_ls
325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343

      -- (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

344 345
      -- Add directories to library search paths, this only has an effect
      -- on Windows. On Unix OSes this function is a NOP.
346
      let all_paths = let paths = takeDirectory (pgm_c dflags)
347
                                : framework_paths
348
                               ++ lib_paths_base
349 350
                               ++ [ takeDirectory dll | DLLPath dll <- libspecs ]
                      in nub $ map normalise paths
351
      let lib_paths = nub $ lib_paths_base ++ gcc_paths
352 353
      all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths
      pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env
354

355
      pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls
356 357
                    cmdline_lib_specs
      maybePutStr dflags "final link ... "
358
      ok <- resolveObjs hsc_env
359 360

      -- DLLs are loaded, reset the search paths
361
      mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache
362 363 364 365 366

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

      return pls1
367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392

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

393 394
classifyLdInput :: DynFlags -> FilePath -> IO (Maybe LibrarySpec)
classifyLdInput dflags f
395 396
  | isObjectFilename platform f = return (Just (Object f))
  | isDynLibFilename platform f = return (Just (DLLPath f))
397
  | otherwise          = do
Ben Gamari's avatar
Ben Gamari committed
398
        putLogMsg dflags NoReason SevInfo noSrcSpan
Sylvain Henry's avatar
Sylvain Henry committed
399
            (defaultUserStyle dflags)
400
            (text ("Warning: ignoring unrecognised input `" ++ f ++ "'"))
401
        return Nothing
402
    where platform = targetPlatform dflags
403

404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451
preloadLib
  :: HscEnv -> [String] -> [String] -> PersistentLinkerState
  -> LibrarySpec -> IO PersistentLinkerState
preloadLib hsc_env lib_paths framework_paths pls lib_spec = do
  maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
  case lib_spec of
    Object static_ish -> do
      (b, pls1) <- preload_static lib_paths static_ish
      maybePutStrLn dflags (if b  then "done" else "not found")
      return pls1

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

    DLL dll_unadorned -> do
      maybe_errstr <- loadDLL hsc_env (mkSOName platform dll_unadorned)
      case maybe_errstr of
         Nothing -> maybePutStrLn dflags "done"
         Just mm | platformOS platform /= OSDarwin ->
           preloadFailed mm lib_paths lib_spec
         Just mm | otherwise -> do
           -- As a backup, on Darwin, try to also load a .so file
           -- since (apparently) some things install that way - see
           -- ticket #8770.
           let libfile = ("lib" ++ dll_unadorned) <.> "so"
           err2 <- loadDLL hsc_env libfile
           case err2 of
             Nothing -> maybePutStrLn dflags "done"
             Just _  -> preloadFailed mm lib_paths lib_spec
      return pls

    DLLPath dll_path -> do
      do maybe_errstr <- loadDLL hsc_env dll_path
         case maybe_errstr of
            Nothing -> maybePutStrLn dflags "done"
            Just mm -> preloadFailed mm lib_paths lib_spec
         return pls

    Framework framework ->
      if platformUsesFrameworks (targetPlatform dflags)
      then do maybe_errstr <- loadFramework hsc_env framework_paths framework
              case maybe_errstr of
                 Nothing -> maybePutStrLn dflags "done"
                 Just mm -> preloadFailed mm framework_paths lib_spec
              return pls
      else panic "preloadLib Framework"
Ian Lynagh's avatar
Ian Lynagh committed
452

453
  where
454 455
    dflags = hsc_dflags hsc_env

456 457
    platform = targetPlatform dflags

458 459
    preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
    preloadFailed sys_errmsg paths spec
460
       = do maybePutStr dflags "failed.\n"
461
            throwGhcExceptionIO $
462
              CmdLineError (
463 464 465 466
                    "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
467
                        intercalate "\n" (map ("   "++) paths)))
468

469
    -- Not interested in the paths in the static case.
Ian Lynagh's avatar
Ian Lynagh committed
470
    preload_static _paths name
471
       = do b <- doesFileExist name
472 473
            if not b then return (False, pls)
                     else if dynamicGhc
474
                             then  do pls1 <- dynLoadObjs hsc_env pls [name]
475
                                      return (True, pls1)
476
                             else  do loadObj hsc_env name
477 478
                                      return (True, pls)

479 480 481
    preload_static_archive _paths name
       = do b <- doesFileExist name
            if not b then return False
482
                     else do if dynamicGhc
483 484
                                 then throwGhcExceptionIO $
                                      CmdLineError dynamic_msg
485
                                 else loadArchive hsc_env name
486
                             return True
487 488 489 490 491 492 493
      where
        dynamic_msg = unlines
          [ "User-specified static library could not be loaded ("
            ++ name ++ ")"
          , "Loading static libraries is not supported in this configuration."
          , "Try using a dynamic library instead."
          ]
494 495


496 497 498 499 500
{- **********************************************************************

                        Link a byte-code expression

  ********************************************************************* -}
501

502
-- | Link a single expression, /including/ first linking packages and
503 504
-- modules that this expression depends on.
--
505 506
-- Raises an IO exception ('ProgramError') if it can't find a compiled
-- version of the dependents to link.
507
--
508
linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue
509
linkExpr hsc_env span root_ul_bco
510 511
  = do {
     -- Initialise the linker (if it's not been done already)
512
   ; initDynLinker hsc_env
513

514 515 516
     -- Extract the DynLinker value for passing into required places
   ; let dl = hsc_dynLinker hsc_env

517
     -- Take lock for the actual work.
518
   ; modifyPLS dl $ \pls0 -> do {
519

520
     -- Link the packages and modules required
521
   ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods
522
   ; if failed ok then
523
        throwGhcExceptionIO (ProgramError "")
524 525
     else do {

526
     -- Link the expression itself
527
     let ie = itbl_env pls
528
         ce = closure_env pls
529

530
     -- Link the necessary packages and linkables
531

532 533 534
   ; let nobreakarray = error "no break array"
         bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)]
   ; resolved <- linkBCO hsc_env ie ce bco_ix nobreakarray root_ul_bco
535
   ; [root_hvref] <- createBCOs hsc_env [resolved]
536 537
   ; fhv <- mkFinalizedHValue hsc_env root_hvref
   ; return (pls, fhv)
538
   }}}
539
   where
540
     free_names = uniqDSetToList (bcoFreeNames root_ul_bco)
541

542
     needed_mods :: [Module]
543
     needed_mods = [ nameModule n | n <- free_names,
544 545 546
                     isExternalName n,      -- Names from other modules
                     not (isWiredInName n)  -- Exclude wired-in names
                   ]                        -- (see note below)
547 548 549 550 551
        -- 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
552
dieWith :: DynFlags -> SrcSpan -> MsgDoc -> IO a
553
dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg)))
554 555


556
checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
557
checkNonStdWay dflags srcspan
558 559 560 561 562
  | gopt Opt_ExternalInterpreter dflags = return Nothing
    -- with -fexternal-interpreter we load the .o files, whatever way
    -- they were built.  If they were built for a non-std way, then
    -- we will use the appropriate variant of the iserv binary to load them.

563 564 565 566 567 568 569 570 571 572 573 574 575
  | 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 ++ "_"
576

577 578 579
normalObjectSuffix :: String
normalObjectSuffix = phaseInputExt StopLn

580
failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
Ian Lynagh's avatar
Ian Lynagh committed
581
failNonStd dflags srcspan = dieWith dflags srcspan $
582 583 584
  text "Cannot load" <+> compWay <+>
     text "objects when GHC is built" <+> ghciWay $$
  text "To fix this, either:" $$
585
  text "  (1) Use -fexternal-interpreter, or" $$
586 587 588 589
  text "  (2) Build the program twice: once" <+>
                       ghciWay <> text ", and then" $$
  text "      with" <+> compWay <+>
     text "using -osuf to set a different object file suffix."
590
    where compWay
591 592 593
            | WayDyn `elem` ways dflags = text "-dynamic"
            | WayProf `elem` ways dflags = text "-prof"
            | otherwise = text "normal"
594
          ghciWay
595 596 597
            | dynamicGhc = text "with -dynamic"
            | rtsIsProfiled = text "with -prof"
            | otherwise = text "the normal way"
598

599 600
getLinkDeps :: HscEnv -> HomePackageTable
            -> PersistentLinkerState
601
            -> Maybe FilePath                   -- replace object suffices?
602 603
            -> SrcSpan                          -- for error messages
            -> [Module]                         -- If you need these
604
            -> IO ([Linkable], [InstalledUnitId])     -- ... then link these first
605
-- Fails with an IO exception if it can't find enough files
606

607
getLinkDeps hsc_env hpt pls replace_osuf span mods
608
-- Find all the packages and linkables that a set of modules depends on
609
 = do {
610
        -- 1.  Find the dependent home-pkg-modules/packages from each iface
611 612
        -- (omitting modules from the interactive package, which is already linked)
      ; (mods_s, pkgs_s) <- follow_deps (filterOut isInteractiveModule mods)
613
                                        emptyUniqDSet emptyUniqDSet;
614

615
      ; let {
616 617 618 619
        -- 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 ;
620

621
            linked_mods = map (moduleName.linkableModule)
622
                                (objs_loaded pls ++ bcos_loaded pls)  }
623 624 625

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

630
      ; return (lnks_needed, pkgs_needed) }
631
  where
Simon Marlow's avatar
Simon Marlow committed
632 633 634
    dflags = hsc_dflags hsc_env
    this_pkg = thisPackage dflags

635 636 637 638 639 640
        -- 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
641
                -> UniqDSet ModuleName         -- accum. module dependencies
642 643
                -> UniqDSet InstalledUnitId          -- accum. package dependencies
                -> IO ([ModuleName], [InstalledUnitId]) -- result
Simon Marlow's avatar
Simon Marlow committed
644
    follow_deps []     acc_mods acc_pkgs
645
        = return (uniqDSetToList acc_mods, uniqDSetToList acc_pkgs)
Simon Marlow's avatar
Simon Marlow committed
646
    follow_deps (mod:mods) acc_mods acc_pkgs
647
        = do
648
          mb_iface <- initIfaceCheck (text "getLinkDeps") hsc_env $
649 650
                        loadInterface msg mod (ImportByUser False)
          iface <- case mb_iface of
651
                    Maybes.Failed err      -> throwGhcExceptionIO (ProgramError (showSDoc dflags err))
652
                    Maybes.Succeeded iface -> return iface
653 654 655 656

          when (mi_boot iface) $ link_boot_mod_error mod

          let
657
            pkg = moduleUnitId mod
658 659 660 661 662 663 664
            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

665 666 667
            boot_deps' = filter (not . (`elementOfUniqDSet` acc_mods)) boot_deps
            acc_mods'  = addListToUniqDSet acc_mods (moduleName mod : mod_deps)
            acc_pkgs'  = addListToUniqDSet acc_pkgs $ map fst pkg_deps
668 669
          --
          if pkg /= this_pkg
670
             then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toInstalledUnitId pkg))
671 672 673 674 675
             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
676 677


678
    link_boot_mod_error mod =
679
        throwGhcExceptionIO (ProgramError (showSDoc dflags (
680
            text "module" <+> ppr mod <+>
Simon Marlow's avatar
Simon Marlow committed
681
            text "cannot be linked; it is only available as a boot module")))
682

683
    no_obj :: Outputable a => a -> IO b
Ian Lynagh's avatar
Ian Lynagh committed
684
    no_obj mod = dieWith dflags span $
685
                     text "cannot find object file for module " <>
686 687 688
                        quotes (ppr mod) $$
                     while_linking_expr

689
    while_linking_expr = text "while linking an interpreted expression"
690

691
        -- This one is a build-system bug
692

693
    get_linkable osuf mod_name      -- A home-package module
niteria's avatar
niteria committed
694
        | Just mod_info <- lookupHpt hpt mod_name
695
        = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))
696 697 698 699 700
        | 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
701
                  Found loc mod -> found loc mod
702
                  _ -> no_obj mod_name
703 704
        where
            found loc mod = do {
705 706 707 708
                -- ...and then find the linkable for it
               mb_lnk <- findObjectLinkableMaybe mod loc ;
               case mb_lnk of {
                  Nothing  -> no_obj mod ;
709
                  Just lnk -> adjust_linkable lnk
710
              }}
711

712
            adjust_linkable lnk
713 714 715
                | Just new_osuf <- replace_osuf = do
                        new_uls <- mapM (adjust_ul new_osuf)
                                        (linkableUnlinked lnk)
716
                        return lnk{ linkableUnlinked=new_uls }
717
                | otherwise =
718
                        return lnk
719

720
            adjust_ul new_osuf (DotO file) = do
721
                MASSERT(osuf `isSuffixOf` file)
722
                let file_base = fromJust (stripExtension osuf file)
723 724 725 726
                    new_file = file_base <.> new_osuf
                ok <- doesFileExist new_file
                if (not ok)
                   then dieWith dflags span $
727
                          text "cannot find object file "
728 729 730 731 732
                                <> 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
733

734

735

736 737
{- **********************************************************************

738
              Loading a Decls statement
739 740 741

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

742
linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO ()
743
linkDecls hsc_env span cbc@CompiledByteCode{..} = do
744
    -- Initialise the linker (if it's not been done already)
745
    initDynLinker hsc_env
746

747 748 749
    -- Extract the DynLinker for passing into required places
    let dl = hsc_dynLinker hsc_env

750
    -- Take lock for the actual work.
751
    modifyPLS dl $ \pls0 -> do
752 753 754 755

    -- Link the packages and modules required
    (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods
    if failed ok
756
      then throwGhcExceptionIO (ProgramError "")
757 758 759
      else do

    -- Link the expression itself
760
    let ie = plusNameEnv (itbl_env pls) bc_itbls
761 762 763
        ce = closure_env pls

    -- Link the necessary packages and linkables
764
    new_bindings <- linkSomeBCOs hsc_env ie ce [cbc]
765 766 767 768
    nms_fhvs <- makeForeignNamedHValueRefs hsc_env new_bindings
    let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs
                   , itbl_env    = ie }
    return (pls2, ())
769
  where
770 771
    free_names = uniqDSetToList $
      foldr (unionUniqDSets . bcoFreeNames) emptyUniqDSet bc_bcos
772 773

    needed_mods :: [Module]
774
    needed_mods = [ nameModule n | n <- free_names,
775 776 777 778 779 780 781 782
                    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.

783 784
{- **********************************************************************

785 786
              Loading a single module

787 788
  ********************************************************************* -}

789 790
linkModule :: HscEnv -> Module -> IO ()
linkModule hsc_env mod = do
791
  initDynLinker hsc_env
792 793
  let dl = hsc_dynLinker hsc_env
  modifyPLS_ dl $ \pls -> do
794
    (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod]
795
    if (failed ok) then throwGhcExceptionIO (ProgramError "could not link module")
796
      else return pls'
797

798 799
{- **********************************************************************

800 801 802
                Link some linkables
        The linkables may consist of a mixture of
        byte-code modules and object modules
803

804 805
  ********************************************************************* -}

806
linkModules :: HscEnv -> PersistentLinkerState -> [Linkable]
807
            -> IO (PersistentLinkerState, SuccessFlag)
808
linkModules hsc_env pls linkables
809
  = mask_ $ do  -- don't want to be interrupted by ^C in here
810 811

        let (objs, bcos) = partition isObjectLinkable
812 813
                              (concatMap partitionLinkable linkables)

814
                -- Load objects first; they can't depend on BCOs
815
        (pls1, ok_flag) <- dynLinkObjs hsc_env pls objs
816 817 818 819

        if failed ok_flag then
                return (pls1, Failed)
          else do
820
                pls2 <- dynLinkBCOs hsc_env pls1 bcos
821
                return (pls2, Succeeded)
822 823 824 825 826 827 828 829


-- 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
830
     in
831
         case (li_uls_obj, li_uls_bco) of
Ian Lynagh's avatar
Ian Lynagh committed
832 833 834
            (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj},
                           li {linkableUnlinked=li_uls_bco}]
            _ -> [li]
835

836
findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
837 838 839 840
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
841
        _    -> pprPanic "findModuleLinkable" (ppr mod)
842 843 844

linkableInSet :: Linkable -> [Linkable] -> Bool
linkableInSet l objs_loaded =
845
  case findModuleLinkable_maybe objs_loaded (linkableModule l) of
846 847
        Nothing -> False
        Just m  -> linkableTime l == linkableTime m
848 849


850 851 852 853 854
{- **********************************************************************

                The object-code linker

  ********************************************************************* -}
855

856
dynLinkObjs :: HscEnv -> PersistentLinkerState -> [Linkable]
857
            -> IO (PersistentLinkerState, SuccessFlag)
858
dynLinkObjs hsc_env pls objs = do
859 860 861 862
        -- 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
863 864
            wanted_objs              = map nameOfObject unlinkeds

865
        if interpreterDynamic (hsc_dflags hsc_env)
866
            then do pls2 <- dynLoadObjs hsc_env pls1 wanted_objs
867
                    return (pls2, Succeeded)
868
            else do mapM_ (loadObj hsc_env) wanted_objs
869 870

                    -- Link them all together
871
                    ok <- resolveObjs hsc_env
872 873 874 875 876 877

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

881

882
dynLoadObjs :: HscEnv -> PersistentLinkerState -> [FilePath]
883
            -> IO PersistentLinkerState
884 885
dynLoadObjs _       pls                           []   = return pls
dynLoadObjs hsc_env pls@PersistentLinkerState{..} objs = do
886
    let dflags = hsc_dflags hsc_env
887
    let platform = targetPlatform dflags
888 889
    let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ]
    let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ]
duog's avatar
duog committed
890 891
    (soFile, libPath , libName) <-
      newTempLibName dflags TFL_CurrentModule (soExt platform)
thomie's avatar
thomie committed
892 893
    let
        dflags2 = dflags {
894 895
                      -- We don't want the original ldInputs in
                      -- (they're already linked in), but we do want
896 897
                      -- to link against previous dynLoadObjs
                      -- libraries if there were any, so that the linker
898 899 900
                      -- can resolve dependencies when it loads this
                      -- library.
                      ldInputs =
Moritz Angermann's avatar
Moritz Angermann committed
901
                           concatMap (\l -> [ Option ("-l" ++ l) ])
902
                                     (nub $ snd <$> temp_sos)
Moritz Angermann's avatar
Moritz Angermann committed
903 904 905 906 907
                        ++ concatMap (\lp -> [ Option ("-L" ++ lp)
                                                    , Option "-Xlinker"
                                                    , Option "-rpath"
                                                    , Option "-Xlinker"
                                                    , Option lp ])
908
                                     (nub $ fst <$> temp_sos)
909 910 911
                        ++ concatMap
                             (\lp ->
                                 [ Option ("-L" ++ lp)
niteria's avatar
niteria committed
912 913 914 915
                                 , Option "-Xlinker"
                                 , Option "-rpath"
                                 , Option "-Xlinker"
                                 , Option lp
916 917
                                 ])
                             minus_big_ls
niteria's avatar
niteria committed
918
                        -- See Note [-Xlinker -rpath vs -Wl,-rpath]
919 920 921
                        ++ map (\l -> Option ("-l" ++ l)) minus_ls,
                      -- Add -l options and -L options from dflags.
                      --
thomie's avatar
thomie committed
922 923 924 925
                      -- When running TH for a non-dynamic way, we still
                      -- need to make -l flags to link against the dynamic
                      -- libraries, so we need to add WayDyn to ways.
                      --
926 927 928 929 930
                      -- 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],
931 932
                      outputFile = Just soFile
                  }
933 934 935
    -- 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.
936
    linkDynLib dflags2 objs pkgs_loaded
duog's avatar
duog committed
937 938 939

    -- if we got this far, extend the lifetime of the library file
    changeTempFilesLifetime dflags TFL_GhcSession [soFile]
940
    m <- loadDLL hsc_env soFile
941
    case m of
942
        Nothing -> return $! pls { temp_sos = (libPath, libName) : temp_sos }
943
        Just err -> panic ("Loading temp shared object failed: " ++ err)
944

945 946 947 948
rmDupLinkables :: [Linkable]    -- Already loaded
               -> [Linkable]    -- New linkables
               -> ([Linkable],  -- New loaded set (including new ones)
                   [Linkable])  -- New linkables (excluding dups)
949 950 951 952 953
rmDupLinkables already ls
  = go already [] ls
  where
    go already extras [] = (already, extras)
    go already extras (l:ls)
954 955
        | linkableInSet l already = go already     extras     ls
        | otherwise               = go (l:already) (l:extras) ls