Linker.lhs 53.1 KB
Newer Older
1
%
Gabor Greif's avatar
typo    
Gabor Greif committed
2
% (c) The University of Glasgow 2005-2012
3
4
%
\begin{code}
5
6
7
8
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

14
module Linker ( 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

56
-- Standard libraries
57
import Control.Monad
58

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

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

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

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


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

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

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

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

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

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

104
105
106
data PersistentLinkerState
   = PersistentLinkerState {

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

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

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

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

123
124
125
126
        -- 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]
127
128
     }

129
emptyPLS :: DynFlags -> PersistentLinkerState
130
131
132
133
134
135
136
137
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
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.
Simon Marlow's avatar
Simon Marlow committed
142
  where init_pkgs = [rtsPackageId]
143

144

145
extendLoadedPkgs :: [PackageId] -> 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
205
withExtendedLinkEnv :: (MonadIO m, ExceptionMonad m) =>
                       [(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
\end{code}

247
248

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

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

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

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

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

298
          -- (d) Link .o files from the command-line
299
300
        ; classified_ld_inputs <- mapM (classifyLdInput dflags)
                                    [ f | FileOption _ f <- cmdline_ld_inputs ]
301

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

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

321
        ; if succeeded ok then maybePutStrLn dflags "done"
322
          else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed")
323
324

        ; return pls
325
        }}
326

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

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

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

363
364
365
366
367
368
369
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"
370
371
372
373
374
375
376
                                                else "not found")

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

377
          DLL dll_unadorned
378
             -> do maybe_errstr <- loadDLL (mkSOName platform dll_unadorned)
379
380
                   case maybe_errstr of
                      Nothing -> maybePutStrLn dflags "done"
Austin Seipp's avatar
Austin Seipp committed
381
382
383
384
385
386
387
388
389
390
                      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
391

392
393
          DLLPath dll_path
             -> do maybe_errstr <- loadDLL dll_path
394
395
396
397
                   case maybe_errstr of
                      Nothing -> maybePutStrLn dflags "done"
                      Just mm -> preloadFailed mm lib_paths lib_spec

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

406
  where
407
408
    platform = targetPlatform dflags

409
410
    preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
    preloadFailed sys_errmsg paths spec
411
       = do maybePutStr dflags "failed.\n"
412
            throwGhcExceptionIO $
413
              CmdLineError (
414
415
416
417
418
                    "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)))))
419

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


438
%************************************************************************
439
440
441
%*                                                                      *
                Link a byte-code expression
%*                                                                      *
442
443
444
%************************************************************************

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

458
     -- Take lock for the actual work.
459
   ; modifyPLS $ \pls0 -> do {
460

461
     -- Link the packages and modules required
462
   ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods
463
   ; if failed ok then
464
        throwGhcExceptionIO (ProgramError "")
465
466
     else do {

467
     -- Link the expression itself
468
     let ie = itbl_env pls
469
         ce = closure_env pls
470

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

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


492
493
494
495
checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
checkNonStdWay dflags srcspan =
  if interpWays == haskellWays
      then return Nothing
496
497
498
499
500
501
502
503
504
    -- 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_.
505
      else if objectSuf dflags == normalObjectSuffix && not (null haskellWays)
506
      then failNonStd dflags srcspan
507
      else return $ Just $ if dynamicGhc
508
509
510
                           then "dyn_o"
                           else "o"
    where haskellWays = filter (not . wayRTSOnly) (ways dflags)
511

512
513
514
normalObjectSuffix :: String
normalObjectSuffix = phaseInputExt StopLn

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

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

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

540
      ; let {
541
542
543
544
        -- 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 ;
545

546
            linked_mods = map (moduleName.linkableModule)
547
                                (objs_loaded pls ++ bcos_loaded pls)  }
548
549
550
551

        -- 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
552
553
      ; let { osuf = objectSuf dflags }
      ; lnks_needed <- mapM (get_linkable osuf) mods_needed
554

555
      ; return (lnks_needed, pkgs_needed) } 
556
  where
Simon Marlow's avatar
Simon Marlow committed
557
558
559
    dflags = hsc_dflags hsc_env
    this_pkg = thisPackage dflags

Simon Marlow's avatar
Simon Marlow committed
560
561
562
563
564
565
566
567
        -- 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
568
                -> IO ([ModuleName], [PackageId]) -- result
Simon Marlow's avatar
Simon Marlow committed
569
    follow_deps []     acc_mods acc_pkgs
570
        = return (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
Simon Marlow's avatar
Simon Marlow committed
571
    follow_deps (mod:mods) acc_mods acc_pkgs
572
573
574
575
        = do
          mb_iface <- initIfaceCheck hsc_env $
                        loadInterface msg mod (ImportByUser False)
          iface <- case mb_iface of
576
                    Maybes.Failed err      -> throwGhcExceptionIO (ProgramError (showSDoc dflags err))
577
                    Maybes.Succeeded iface -> return iface
578
579
580
581
582
583
584
585
586
587
588
589
590
591

          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)
592
            acc_pkgs'  = addListToUniqSet acc_pkgs $ map fst pkg_deps
593
594
595
596
597
598
599
600
          --
          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
601
602


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

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

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

616
        -- This one is a build-system bug
617

618
    get_linkable osuf mod_name      -- A home-package module
619
620
621
622
623
624
625
626
627
        | 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
628
629
        where
            found loc mod = do {
630
631
632
633
634
635
                -- ...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
              }}
636

637
            adjust_linkable lnk
638
639
640
                | Just new_osuf <- replace_osuf = do
                        new_uls <- mapM (adjust_ul new_osuf)
                                        (linkableUnlinked lnk)
641
                        return lnk{ linkableUnlinked=new_uls }
642
643
644
                | otherwise =
                        return lnk

645
            adjust_ul new_osuf (DotO file) = do
646
                MASSERT(osuf `isSuffixOf` file)
647
                let file_base = dropTail (length osuf + 1) file
648
649
650
651
652
653
654
655
656
657
                    new_file = file_base <.> new_osuf
                ok <- doesFileExist new_file
                if (not ok)
                   then dieWith dflags span $
                          ptext (sLit "cannot find normal object file ")
                                <> quotes (text new_file) $$ while_linking_expr
                   else return (DotO new_file)
            adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp)
            adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp)
            adjust_ul _ l@(BCOs {}) = return l
658
\end{code}
659

660
661

%************************************************************************
662
%*                                                                      *
663
              Loading a Decls statement
664
%*                                                                      *
665
666
667
668
669
670
671
672
673
674
675
676
677
678
%************************************************************************
\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
679
      then throwGhcExceptionIO (ProgramError "")
680
681
682
683
684
685
686
      else do

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

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

    needed_mods :: [Module]
695
    needed_mods = [ nameModule n | n <- free_names,
696
697
698
699
700
701
702
703
704
705
706
                    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}



707
%************************************************************************
708
%*                                                                      *
709
              Loading a single module
710
%*                                                                      *
711
712
%************************************************************************

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

%************************************************************************
724
725
726
727
728
%*                                                                      *
                Link some linkables
        The linkables may consist of a mixture of
        byte-code modules and object modules
%*                                                                      *
729
730
731
%************************************************************************

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

        let (objs, bcos) = partition isObjectLinkable
738
739
                              (concatMap partitionLinkable linkables)

740
741
742
743
744
745
                -- 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
746
                pls2 <- dynLinkBCOs dflags pls1 bcos
747
                return (pls2, Succeeded)
748
749
750
751
752
753
754
755


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

762
findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
763
764
765
766
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
767
        _    -> pprPanic "findModuleLinkable" (ppr mod)
768
769
770

linkableInSet :: Linkable -> [Linkable] -> Bool
linkableInSet l objs_loaded =
771
  case findModuleLinkable_maybe objs_loaded (linkableModule l) of
772
773
        Nothing -> False
        Just m  -> linkableTime l == linkableTime m
774
775
776
777
\end{code}


%************************************************************************
778
%*                                                                      *
779
\subsection{The object-code linker}
780
%*                                                                      *
781
782
783
%************************************************************************

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

793
        if dynamicGhc
794
            then do dynLoadObjs dflags wanted_objs
795
                    return (pls1, Succeeded)
796
797
798
799
800
801
802
803
804
805
806
807
808
809
            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)

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

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

%************************************************************************
851
%*                                                                      *
852
\subsection{The byte-code linker}
853
%*                                                                      *
854
855
856
%************************************************************************

\begin{code}
857
858
859
dynLinkBCOs :: DynFlags -> PersistentLinkerState -> [Linkable]
            -> IO PersistentLinkerState
dynLinkBCOs dflags pls bcos = do
860

861
862
863
864
865
866
867
868
869
870
871
872
        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
873
874
            final_ie  = foldr plusNameEnv (itbl_env pls) ies

875
        (final_gce, _linked_bcos) <- linkSomeBCOs dflags True final_ie gce ul_bcos
876
                -- XXX What happens to these linked_bcos?
877

878
879
        let pls2 = pls1 { closure_env = final_gce,
                          itbl_env    = final_ie }
880

881
        return pls2
882
883

-- Link a bunch of BCOs and return them + updated closure env.
884
885
linkSomeBCOs :: DynFlags
             -> Bool    -- False <=> add _all_ BCOs to returned closure env
886
                        -- True  <=> add only toplevel BCOs to closure env
887
888
             -> ItblEnv
             -> ClosureEnv
889
             -> [UnlinkedBCO]
890
             -> IO (ClosureEnv, [HValue])
891
892
893
894
                        -- The returned HValues are associated 1-1 with
                        -- the incoming unlinked BCOs.  Each gives the
                        -- value of the corresponding unlinked BCO

895
linkSomeBCOs dflags toplevs_only ie ce_in ul_bcos
896
   = do let nms = map unlinkedBCOName ul_bcos
897
        hvals <- fixIO
898
                    ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
899
                               in  mapM (linkBCO dflags ie ce_out) ul_bcos )
900
901
        let ce_all_additions = zip nms hvals
            ce_top_additions = filter (isExternalName.fst) ce_all_additions
902
            ce_additions     = if toplevs_only then ce_top_additions
903
                                               else ce_all_additions
904
905
            ce_out = -- make sure we're not inserting duplicate names into the
                     -- closure environment, which leads to trouble.
906
                     ASSERT(all (not . (`elemNameEnv` ce_in)) (map fst ce_additions))
907
                     extendClosureEnv ce_in ce_additions
908
        return (ce_out, hvals)
909

910
911
912
913
\end{code}


%************************************************************************
914
915
916
%*                                                                      *
                Unload some object modules
%*                                                                      *
917
918
919
%************************************************************************

\begin{code}
sof's avatar
sof committed
920
-- ---------------------------------------------------------------------------
921
-- | Unloading old objects ready for a new compilation sweep.
922
923
--
-- The compilation manager provides us with a list of linkables that it
924
-- considers \"stable\", i.e. won't be recompiled this time around.  For
925
926
-- each of the modules current linked in memory,
--
927
928
--   * if the linkable is stable (and it's the same one -- the user may have
--     recompiled the module on the side), we keep it,
929
--
930
--   * otherwise, we unload it.
931
--
932
933
934
935
936
--   * we also implicitly unload all temporary bindings at this point.
--
unload :: DynFlags
       -> [Linkable] -- ^ The linkables to *keep*.
       -> IO ()
937
unload dflags linkables
938
  = mask_ $ do -- mask, so we're safe from Ctrl-C in here
sof's avatar
sof committed
939

940
941
942
943
        -- Initialise the linker (if it's not been done already)
        initDynLinker dflags

        new_pls
944
            <- modifyPLS $ \pls -> do
945
                 pls1 <- unload_wkr dflags linkables pls
946
                 return (pls1, pls1)
947

948
949
950
        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 ()
951

952
unload_wkr :: DynFlags
953
954
           -> [Linkable]                -- stable linkables
           -> PersistentLinkerState
955
956
957
           -> IO PersistentLinkerState
-- Does the core unload business
-- (the wrapper blocks exceptions and deals with the PLS get and put)
958

Ian Lynagh's avatar
Ian Lynagh committed
959
unload_wkr _ linkables pls
960
  = do  let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
961

962
        objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls)
963
964
        bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)

965
966
        let bcos_retained = map linkableModule bcos_loaded'
            itbl_env'     = filterNameMap bcos_retained (itbl_env pls)
967
            closure_env'  = filterNameMap bcos_retained (closure_env pls)
968
969
970
971
            new_pls = pls { itbl_env = itbl_env',
                            closure_env = closure_env',
                            bcos_loaded = bcos_loaded',
                            objs_loaded = objs_loaded' }
972

973
        return new_pls
974
975
976
  where
    maybeUnload :: [Linkable] -> Linkable -> IO Bool
    maybeUnload keep_linkables lnk
977
      | linkableInSet lnk keep_linkables = return True
978
979
      -- We don't do any cleanup when linking objects with the dynamic linker.
      -- Doing so introduces extra complexity for not much benefit.
980
      | dynamicGhc = return False
981
      | otherwise
982
      = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk]
983
984
985
986
987
988
989
                -- 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
990
991
992
993
\end{code}


%************************************************************************
994
995
996
%*                                                                      *
                Loading packages
%*                                                                      *
997
998
999
1000
%************************************************************************


\begin{code}
1001
1002
1003
1004
1005
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.
1006

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

1009
1010
1011
1012
1013
   | DLL String         -- "Unadorned" name of a .DLL/.so
                        --  e.g.    On unix     "qt"  denotes "libqt.so"
                        --          On WinDoze  "burble"  denotes "burble.DLL"
                        --  loadDLL is platform-specific and adds the lib/.so/.DLL
                        --  suffixes platform-dependently
1014

1015
   | DLLPath FilePath   -- Absolute or relative pathname to a dynamic library
1016
                        -- (ends with .dll or .so).
1017

1018
   | Framework String   -- Only used for darwin, but does no harm
1019
1020
1021
1022

-- If this package is already part of the GHCi binary, we'll already
-- have the right DLLs for this package loaded, so don't try to
-- load them again.
1023
--
1024
1025
-- But on Win32 we must load them 'again'; doing so is a harmless no-op
-- as far as the loader is concerned, but it does initialise the list
1026
1027
-- of DLL handles that rts/Linker.c maintains, and that in turn is
-- used by lookupSymbol.  So we must call addDLL for each library
1028
-- just to get the DLL handle into the list.
Ian Lynagh's avatar
Ian Lynagh committed
1029
partOfGHCi :: [PackageName]
1030
partOfGHCi
1031
 | isWindowsHost || isDarwinHost = []
Ian Lynagh's avatar
Ian Lynagh committed
1032
 | otherwise = map PackageName