Tweak link order slightly to prefer user shared libs before system ones.
[ghc.git] / compiler / ghci / Linker.hs
1 {-# LANGUAGE CPP, NondecreasingIndentation, TupleSections, RecordWildCards #-}
2 {-# OPTIONS_GHC -fno-cse #-}
3 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
4
5 --
6 -- (c) The University of Glasgow 2002-2006
7 --
8 -- | The dynamic linker for GHCi.
9 --
10 -- This module deals with the top-level issues of dynamic linking,
11 -- calling the object-code linker and the byte-code linker where
12 -- necessary.
13 module Linker ( getHValue, showLinkerState,
14 linkExpr, linkDecls, unload, withExtendedLinkEnv,
15 extendLinkEnv, deleteFromLinkEnv,
16 extendLoadedPkgs,
17 linkPackages,initDynLinker,linkModule,
18 linkCmdLineLibs
19 ) where
20
21 #include "HsVersions.h"
22
23 import GhcPrelude
24
25 import GHCi
26 import GHCi.RemoteTypes
27 import LoadIface
28 import ByteCodeLink
29 import ByteCodeAsm
30 import ByteCodeTypes
31 import TcRnMonad
32 import Packages
33 import DriverPhases
34 import Finder
35 import HscTypes
36 import Name
37 import NameEnv
38 import Module
39 import ListSetOps
40 import DynFlags
41 import BasicTypes
42 import Outputable
43 import Panic
44 import Util
45 import ErrUtils
46 import SrcLoc
47 import qualified Maybes
48 import UniqDSet
49 import FastString
50 import Platform
51 import SysTools
52 import FileCleanup
53
54 -- Standard libraries
55 import Control.Monad
56
57 import Data.Char (isSpace)
58 import Data.IORef
59 import Data.List
60 import Data.Maybe
61 import Control.Concurrent.MVar
62
63 import System.FilePath
64 import System.Directory
65 import System.IO.Unsafe
66
67 #if defined(mingw32_HOST_OS)
68 import System.Win32.Info (getSystemDirectory)
69 #endif
70
71 import Exception
72
73 import Foreign (Ptr) -- needed for 2nd stage
74
75 {- **********************************************************************
76
77 The Linker's state
78
79 ********************************************************************* -}
80
81 {-
82 The persistent linker state *must* match the actual state of the
83 C dynamic linker at all times, so we keep it in a private global variable.
84
85 The global IORef used for PersistentLinkerState actually contains another MVar.
86 The reason for this is that we want to allow another loaded copy of the GHC
87 library to side-effect the PLS and for those changes to be reflected here.
88
89 The PersistentLinkerState maps Names to actual closures (for
90 interpreted code only), for use during linking.
91 -}
92 #if STAGE < 2
93 GLOBAL_VAR_M(v_PersistentLinkerState, newMVar (panic "Dynamic linker not initialised"), MVar PersistentLinkerState)
94 GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised
95 #else
96 SHARED_GLOBAL_VAR_M( v_PersistentLinkerState
97 , getOrSetLibHSghcPersistentLinkerState
98 , "getOrSetLibHSghcPersistentLinkerState"
99 , newMVar (panic "Dynamic linker not initialised")
100 , MVar PersistentLinkerState)
101 -- Set True when dynamic linker is initialised
102 SHARED_GLOBAL_VAR( v_InitLinkerDone
103 , getOrSetLibHSghcInitLinkerDone
104 , "getOrSetLibHSghcInitLinkerDone"
105 , False
106 , Bool)
107 #endif
108
109 modifyPLS_ :: (PersistentLinkerState -> IO PersistentLinkerState) -> IO ()
110 modifyPLS_ f = readIORef v_PersistentLinkerState >>= flip modifyMVar_ f
111
112 modifyPLS :: (PersistentLinkerState -> IO (PersistentLinkerState, a)) -> IO a
113 modifyPLS f = readIORef v_PersistentLinkerState >>= flip modifyMVar f
114
115 data PersistentLinkerState
116 = PersistentLinkerState {
117
118 -- Current global mapping from Names to their true values
119 closure_env :: ClosureEnv,
120
121 -- The current global mapping from RdrNames of DataCons to
122 -- info table addresses.
123 -- When a new Unlinked is linked into the running image, or an existing
124 -- module in the image is replaced, the itbl_env must be updated
125 -- appropriately.
126 itbl_env :: !ItblEnv,
127
128 -- The currently loaded interpreted modules (home package)
129 bcos_loaded :: ![Linkable],
130
131 -- And the currently-loaded compiled modules (home package)
132 objs_loaded :: ![Linkable],
133
134 -- The currently-loaded packages; always object code
135 -- Held, as usual, in dependency order; though I am not sure if
136 -- that is really important
137 pkgs_loaded :: ![LinkerUnitId],
138
139 -- we need to remember the name of previous temporary DLL/.so
140 -- libraries so we can link them (see #10322)
141 temp_sos :: ![(FilePath, String)] }
142
143
144 emptyPLS :: DynFlags -> PersistentLinkerState
145 emptyPLS _ = PersistentLinkerState {
146 closure_env = emptyNameEnv,
147 itbl_env = emptyNameEnv,
148 pkgs_loaded = init_pkgs,
149 bcos_loaded = [],
150 objs_loaded = [],
151 temp_sos = [] }
152
153 -- Packages that don't need loading, because the compiler
154 -- shares them with the interpreted program.
155 --
156 -- The linker's symbol table is populated with RTS symbols using an
157 -- explicit list. See rts/Linker.c for details.
158 where init_pkgs = map toInstalledUnitId [rtsUnitId]
159
160
161 extendLoadedPkgs :: [InstalledUnitId] -> IO ()
162 extendLoadedPkgs pkgs =
163 modifyPLS_ $ \s ->
164 return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }
165
166 extendLinkEnv :: [(Name,ForeignHValue)] -> IO ()
167 extendLinkEnv new_bindings =
168 modifyPLS_ $ \pls -> do
169 let ce = closure_env pls
170 let new_ce = extendClosureEnv ce new_bindings
171 return pls{ closure_env = new_ce }
172
173 deleteFromLinkEnv :: [Name] -> IO ()
174 deleteFromLinkEnv to_remove =
175 modifyPLS_ $ \pls -> do
176 let ce = closure_env pls
177 let new_ce = delListFromNameEnv ce to_remove
178 return pls{ closure_env = new_ce }
179
180 -- | Get the 'HValue' associated with the given name.
181 --
182 -- May cause loading the module that contains the name.
183 --
184 -- Throws a 'ProgramError' if loading fails or the name cannot be found.
185 getHValue :: HscEnv -> Name -> IO ForeignHValue
186 getHValue hsc_env name = do
187 initDynLinker hsc_env
188 pls <- modifyPLS $ \pls -> do
189 if (isExternalName name) then do
190 (pls', ok) <- linkDependencies hsc_env pls noSrcSpan
191 [nameModule name]
192 if (failed ok) then throwGhcExceptionIO (ProgramError "")
193 else return (pls', pls')
194 else
195 return (pls, pls)
196 case lookupNameEnv (closure_env pls) name of
197 Just (_,aa) -> return aa
198 Nothing
199 -> ASSERT2(isExternalName name, ppr name)
200 do let sym_to_find = nameToCLabel name "closure"
201 m <- lookupClosure hsc_env (unpackFS sym_to_find)
202 case m of
203 Just hvref -> mkFinalizedHValue hsc_env hvref
204 Nothing -> linkFail "ByteCodeLink.lookupCE"
205 (unpackFS sym_to_find)
206
207 linkDependencies :: HscEnv -> PersistentLinkerState
208 -> SrcSpan -> [Module]
209 -> IO (PersistentLinkerState, SuccessFlag)
210 linkDependencies hsc_env pls span needed_mods = do
211 -- initDynLinker (hsc_dflags hsc_env)
212 let hpt = hsc_HPT hsc_env
213 dflags = hsc_dflags hsc_env
214 -- The interpreter and dynamic linker can only handle object code built
215 -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
216 -- So here we check the build tag: if we're building a non-standard way
217 -- then we need to find & link object files built the "normal" way.
218 maybe_normal_osuf <- checkNonStdWay dflags span
219
220 -- Find what packages and linkables are required
221 (lnks, pkgs) <- getLinkDeps hsc_env hpt pls
222 maybe_normal_osuf span needed_mods
223
224 -- Link the packages and modules required
225 pls1 <- linkPackages' hsc_env pkgs pls
226 linkModules hsc_env pls1 lnks
227
228
229 -- | Temporarily extend the linker state.
230
231 withExtendedLinkEnv :: (ExceptionMonad m) =>
232 [(Name,ForeignHValue)] -> m a -> m a
233 withExtendedLinkEnv new_env action
234 = gbracket (liftIO $ extendLinkEnv new_env)
235 (\_ -> reset_old_env)
236 (\_ -> action)
237 where
238 -- Remember that the linker state might be side-effected
239 -- during the execution of the IO action, and we don't want to
240 -- lose those changes (we might have linked a new module or
241 -- package), so the reset action only removes the names we
242 -- added earlier.
243 reset_old_env = liftIO $ do
244 modifyPLS_ $ \pls ->
245 let cur = closure_env pls
246 new = delListFromNameEnv cur (map fst new_env)
247 in return pls{ closure_env = new }
248
249
250 -- | Display the persistent linker state.
251 showLinkerState :: DynFlags -> IO ()
252 showLinkerState dflags
253 = do pls <- readIORef v_PersistentLinkerState >>= readMVar
254 putLogMsg dflags NoReason SevDump noSrcSpan
255 (defaultDumpStyle dflags)
256 (vcat [text "----- Linker state -----",
257 text "Pkgs:" <+> ppr (pkgs_loaded pls),
258 text "Objs:" <+> ppr (objs_loaded pls),
259 text "BCOs:" <+> ppr (bcos_loaded pls)])
260
261
262 {- **********************************************************************
263
264 Initialisation
265
266 ********************************************************************* -}
267
268 -- | Initialise the dynamic linker. This entails
269 --
270 -- a) Calling the C initialisation procedure,
271 --
272 -- b) Loading any packages specified on the command line,
273 --
274 -- c) Loading any packages specified on the command line, now held in the
275 -- @-l@ options in @v_Opt_l@,
276 --
277 -- d) Loading any @.o\/.dll@ files specified on the command line, now held
278 -- in @ldInputs@,
279 --
280 -- e) Loading any MacOS frameworks.
281 --
282 -- NOTE: This function is idempotent; if called more than once, it does
283 -- nothing. This is useful in Template Haskell, where we call it before
284 -- trying to link.
285 --
286 initDynLinker :: HscEnv -> IO ()
287 initDynLinker hsc_env =
288 modifyPLS_ $ \pls0 -> do
289 done <- readIORef v_InitLinkerDone
290 if done then return pls0
291 else do writeIORef v_InitLinkerDone True
292 reallyInitDynLinker hsc_env
293
294 reallyInitDynLinker :: HscEnv -> IO PersistentLinkerState
295 reallyInitDynLinker hsc_env = do
296 -- Initialise the linker state
297 let dflags = hsc_dflags hsc_env
298 pls0 = emptyPLS dflags
299
300 -- (a) initialise the C dynamic linker
301 initObjLinker hsc_env
302
303 -- (b) Load packages from the command-line (Note [preload packages])
304 pls <- linkPackages' hsc_env (preloadPackages (pkgState dflags)) pls0
305
306 -- steps (c), (d) and (e)
307 linkCmdLineLibs' hsc_env pls
308
309
310 linkCmdLineLibs :: HscEnv -> IO ()
311 linkCmdLineLibs hsc_env = do
312 initDynLinker hsc_env
313 modifyPLS_ $ \pls -> do
314 linkCmdLineLibs' hsc_env pls
315
316 linkCmdLineLibs' :: HscEnv -> PersistentLinkerState -> IO PersistentLinkerState
317 linkCmdLineLibs' hsc_env pls =
318 do
319 let dflags@(DynFlags { ldInputs = cmdline_ld_inputs
320 , libraryPaths = lib_paths_base})
321 = hsc_dflags hsc_env
322
323 -- (c) Link libraries from the command-line
324 let minus_ls_1 = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ]
325
326 -- On Windows we want to add libpthread by default just as GCC would.
327 -- However because we don't know the actual name of pthread's dll we
328 -- need to defer this to the locateLib call so we can't initialize it
329 -- inside of the rts. Instead we do it here to be able to find the
330 -- import library for pthreads. See Trac #13210.
331 let platform = targetPlatform dflags
332 os = platformOS platform
333 minus_ls = case os of
334 OSMinGW32 -> "pthread" : minus_ls_1
335 _ -> minus_ls_1
336 -- See Note [Fork/Exec Windows]
337 gcc_paths <- getGCCPaths dflags os
338
339 maybePutStrLn dflags "Search directories (user):"
340 maybePutStr dflags (unlines $ map (" "++) lib_paths_base)
341 maybePutStrLn dflags "Search directories (gcc):"
342 maybePutStr dflags (unlines $ map (" "++) gcc_paths)
343
344 libspecs
345 <- mapM (locateLib hsc_env False lib_paths_base gcc_paths) minus_ls
346
347 -- (d) Link .o files from the command-line
348 classified_ld_inputs <- mapM (classifyLdInput dflags)
349 [ f | FileOption _ f <- cmdline_ld_inputs ]
350
351 -- (e) Link any MacOS frameworks
352 let platform = targetPlatform dflags
353 let (framework_paths, frameworks) =
354 if platformUsesFrameworks platform
355 then (frameworkPaths dflags, cmdlineFrameworks dflags)
356 else ([],[])
357
358 -- Finally do (c),(d),(e)
359 let cmdline_lib_specs = catMaybes classified_ld_inputs
360 ++ libspecs
361 ++ map Framework frameworks
362 if null cmdline_lib_specs then return pls
363 else do
364
365 -- Add directories to library search paths, this only has an effect
366 -- on Windows. On Unix OSes this function is a NOP.
367 let all_paths = let paths = takeDirectory (fst $ sPgm_c $ settings dflags)
368 : framework_paths
369 ++ lib_paths_base
370 ++ [ takeDirectory dll | DLLPath dll <- libspecs ]
371 in nub $ map normalise paths
372 let lib_paths = nub $ lib_paths_base ++ gcc_paths
373 pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths
374
375 pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls
376 cmdline_lib_specs
377 maybePutStr dflags "final link ... "
378 ok <- resolveObjs hsc_env
379
380 -- DLLs are loaded, reset the search paths
381 mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache
382
383 if succeeded ok then maybePutStrLn dflags "done"
384 else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed")
385
386 return pls1
387
388 {- Note [preload packages]
389
390 Why do we need to preload packages from the command line? This is an
391 explanation copied from #2437:
392
393 I tried to implement the suggestion from #3560, thinking it would be
394 easy, but there are two reasons we link in packages eagerly when they
395 are mentioned on the command line:
396
397 * So that you can link in extra object files or libraries that
398 depend on the packages. e.g. ghc -package foo -lbar where bar is a
399 C library that depends on something in foo. So we could link in
400 foo eagerly if and only if there are extra C libs or objects to
401 link in, but....
402
403 * Haskell code can depend on a C function exported by a package, and
404 the normal dependency tracking that TH uses can't know about these
405 dependencies. The test ghcilink004 relies on this, for example.
406
407 I conclude that we need two -package flags: one that says "this is a
408 package I want to make available", and one that says "this is a
409 package I want to link in eagerly". Would that be too complicated for
410 users?
411 -}
412
413 classifyLdInput :: DynFlags -> FilePath -> IO (Maybe LibrarySpec)
414 classifyLdInput dflags f
415 | isObjectFilename platform f = return (Just (Object f))
416 | isDynLibFilename platform f = return (Just (DLLPath f))
417 | otherwise = do
418 putLogMsg dflags NoReason SevInfo noSrcSpan
419 (defaultUserStyle dflags)
420 (text ("Warning: ignoring unrecognised input `" ++ f ++ "'"))
421 return Nothing
422 where platform = targetPlatform dflags
423
424 preloadLib
425 :: HscEnv -> [String] -> [String] -> PersistentLinkerState
426 -> LibrarySpec -> IO PersistentLinkerState
427 preloadLib hsc_env lib_paths framework_paths pls lib_spec = do
428 maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
429 case lib_spec of
430 Object static_ish -> do
431 (b, pls1) <- preload_static lib_paths static_ish
432 maybePutStrLn dflags (if b then "done" else "not found")
433 return pls1
434
435 Archive static_ish -> do
436 b <- preload_static_archive lib_paths static_ish
437 maybePutStrLn dflags (if b then "done" else "not found")
438 return pls
439
440 DLL dll_unadorned -> do
441 maybe_errstr <- loadDLL hsc_env (mkSOName platform dll_unadorned)
442 case maybe_errstr of
443 Nothing -> maybePutStrLn dflags "done"
444 Just mm | platformOS platform /= OSDarwin ->
445 preloadFailed mm lib_paths lib_spec
446 Just mm | otherwise -> do
447 -- As a backup, on Darwin, try to also load a .so file
448 -- since (apparently) some things install that way - see
449 -- ticket #8770.
450 let libfile = ("lib" ++ dll_unadorned) <.> "so"
451 err2 <- loadDLL hsc_env libfile
452 case err2 of
453 Nothing -> maybePutStrLn dflags "done"
454 Just _ -> preloadFailed mm lib_paths lib_spec
455 return pls
456
457 DLLPath dll_path -> do
458 do maybe_errstr <- loadDLL hsc_env dll_path
459 case maybe_errstr of
460 Nothing -> maybePutStrLn dflags "done"
461 Just mm -> preloadFailed mm lib_paths lib_spec
462 return pls
463
464 Framework framework ->
465 if platformUsesFrameworks (targetPlatform dflags)
466 then do maybe_errstr <- loadFramework hsc_env framework_paths framework
467 case maybe_errstr of
468 Nothing -> maybePutStrLn dflags "done"
469 Just mm -> preloadFailed mm framework_paths lib_spec
470 return pls
471 else panic "preloadLib Framework"
472
473 where
474 dflags = hsc_dflags hsc_env
475
476 platform = targetPlatform dflags
477
478 preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
479 preloadFailed sys_errmsg paths spec
480 = do maybePutStr dflags "failed.\n"
481 throwGhcExceptionIO $
482 CmdLineError (
483 "user specified .o/.so/.DLL could not be loaded ("
484 ++ sys_errmsg ++ ")\nWhilst trying to load: "
485 ++ showLS spec ++ "\nAdditional directories searched:"
486 ++ (if null paths then " (none)" else
487 intercalate "\n" (map (" "++) paths)))
488
489 -- Not interested in the paths in the static case.
490 preload_static _paths name
491 = do b <- doesFileExist name
492 if not b then return (False, pls)
493 else if dynamicGhc
494 then do pls1 <- dynLoadObjs hsc_env pls [name]
495 return (True, pls1)
496 else do loadObj hsc_env name
497 return (True, pls)
498
499 preload_static_archive _paths name
500 = do b <- doesFileExist name
501 if not b then return False
502 else do if dynamicGhc
503 then panic "Loading archives not supported"
504 else loadArchive hsc_env name
505 return True
506
507
508 {- **********************************************************************
509
510 Link a byte-code expression
511
512 ********************************************************************* -}
513
514 -- | Link a single expression, /including/ first linking packages and
515 -- modules that this expression depends on.
516 --
517 -- Raises an IO exception ('ProgramError') if it can't find a compiled
518 -- version of the dependents to link.
519 --
520 linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue
521 linkExpr hsc_env span root_ul_bco
522 = do {
523 -- Initialise the linker (if it's not been done already)
524 ; initDynLinker hsc_env
525
526 -- Take lock for the actual work.
527 ; modifyPLS $ \pls0 -> do {
528
529 -- Link the packages and modules required
530 ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods
531 ; if failed ok then
532 throwGhcExceptionIO (ProgramError "")
533 else do {
534
535 -- Link the expression itself
536 let ie = itbl_env pls
537 ce = closure_env pls
538
539 -- Link the necessary packages and linkables
540
541 ; let nobreakarray = error "no break array"
542 bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)]
543 ; resolved <- linkBCO hsc_env ie ce bco_ix nobreakarray root_ul_bco
544 ; [root_hvref] <- createBCOs hsc_env [resolved]
545 ; fhv <- mkFinalizedHValue hsc_env root_hvref
546 ; return (pls, fhv)
547 }}}
548 where
549 free_names = uniqDSetToList (bcoFreeNames root_ul_bco)
550
551 needed_mods :: [Module]
552 needed_mods = [ nameModule n | n <- free_names,
553 isExternalName n, -- Names from other modules
554 not (isWiredInName n) -- Exclude wired-in names
555 ] -- (see note below)
556 -- Exclude wired-in names because we may not have read
557 -- their interface files, so getLinkDeps will fail
558 -- All wired-in names are in the base package, which we link
559 -- by default, so we can safely ignore them here.
560
561 dieWith :: DynFlags -> SrcSpan -> MsgDoc -> IO a
562 dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg)))
563
564
565 checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
566 checkNonStdWay dflags srcspan
567 | gopt Opt_ExternalInterpreter dflags = return Nothing
568 -- with -fexternal-interpreter we load the .o files, whatever way
569 -- they were built. If they were built for a non-std way, then
570 -- we will use the appropriate variant of the iserv binary to load them.
571
572 | interpWays == haskellWays = return Nothing
573 -- Only if we are compiling with the same ways as GHC is built
574 -- with, can we dynamically load those object files. (see #3604)
575
576 | objectSuf dflags == normalObjectSuffix && not (null haskellWays)
577 = failNonStd dflags srcspan
578
579 | otherwise = return (Just (interpTag ++ "o"))
580 where
581 haskellWays = filter (not . wayRTSOnly) (ways dflags)
582 interpTag = case mkBuildTag interpWays of
583 "" -> ""
584 tag -> tag ++ "_"
585
586 normalObjectSuffix :: String
587 normalObjectSuffix = phaseInputExt StopLn
588
589 failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
590 failNonStd dflags srcspan = dieWith dflags srcspan $
591 text "Cannot load" <+> compWay <+>
592 text "objects when GHC is built" <+> ghciWay $$
593 text "To fix this, either:" $$
594 text " (1) Use -fexternal-interpreter, or" $$
595 text " (2) Build the program twice: once" <+>
596 ghciWay <> text ", and then" $$
597 text " with" <+> compWay <+>
598 text "using -osuf to set a different object file suffix."
599 where compWay
600 | WayDyn `elem` ways dflags = text "-dynamic"
601 | WayProf `elem` ways dflags = text "-prof"
602 | otherwise = text "normal"
603 ghciWay
604 | dynamicGhc = text "with -dynamic"
605 | rtsIsProfiled = text "with -prof"
606 | otherwise = text "the normal way"
607
608 getLinkDeps :: HscEnv -> HomePackageTable
609 -> PersistentLinkerState
610 -> Maybe FilePath -- replace object suffices?
611 -> SrcSpan -- for error messages
612 -> [Module] -- If you need these
613 -> IO ([Linkable], [InstalledUnitId]) -- ... then link these first
614 -- Fails with an IO exception if it can't find enough files
615
616 getLinkDeps hsc_env hpt pls replace_osuf span mods
617 -- Find all the packages and linkables that a set of modules depends on
618 = do {
619 -- 1. Find the dependent home-pkg-modules/packages from each iface
620 -- (omitting modules from the interactive package, which is already linked)
621 ; (mods_s, pkgs_s) <- follow_deps (filterOut isInteractiveModule mods)
622 emptyUniqDSet emptyUniqDSet;
623
624 ; let {
625 -- 2. Exclude ones already linked
626 -- Main reason: avoid findModule calls in get_linkable
627 mods_needed = mods_s `minusList` linked_mods ;
628 pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ;
629
630 linked_mods = map (moduleName.linkableModule)
631 (objs_loaded pls ++ bcos_loaded pls) }
632
633 -- 3. For each dependent module, find its linkable
634 -- This will either be in the HPT or (in the case of one-shot
635 -- compilation) we may need to use maybe_getFileLinkable
636 ; let { osuf = objectSuf dflags }
637 ; lnks_needed <- mapM (get_linkable osuf) mods_needed
638
639 ; return (lnks_needed, pkgs_needed) }
640 where
641 dflags = hsc_dflags hsc_env
642 this_pkg = thisPackage dflags
643
644 -- The ModIface contains the transitive closure of the module dependencies
645 -- within the current package, *except* for boot modules: if we encounter
646 -- a boot module, we have to find its real interface and discover the
647 -- dependencies of that. Hence we need to traverse the dependency
648 -- tree recursively. See bug #936, testcase ghci/prog007.
649 follow_deps :: [Module] -- modules to follow
650 -> UniqDSet ModuleName -- accum. module dependencies
651 -> UniqDSet InstalledUnitId -- accum. package dependencies
652 -> IO ([ModuleName], [InstalledUnitId]) -- result
653 follow_deps [] acc_mods acc_pkgs
654 = return (uniqDSetToList acc_mods, uniqDSetToList acc_pkgs)
655 follow_deps (mod:mods) acc_mods acc_pkgs
656 = do
657 mb_iface <- initIfaceCheck (text "getLinkDeps") hsc_env $
658 loadInterface msg mod (ImportByUser False)
659 iface <- case mb_iface of
660 Maybes.Failed err -> throwGhcExceptionIO (ProgramError (showSDoc dflags err))
661 Maybes.Succeeded iface -> return iface
662
663 when (mi_boot iface) $ link_boot_mod_error mod
664
665 let
666 pkg = moduleUnitId mod
667 deps = mi_deps iface
668
669 pkg_deps = dep_pkgs deps
670 (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps)
671 where is_boot (m,True) = Left m
672 is_boot (m,False) = Right m
673
674 boot_deps' = filter (not . (`elementOfUniqDSet` acc_mods)) boot_deps
675 acc_mods' = addListToUniqDSet acc_mods (moduleName mod : mod_deps)
676 acc_pkgs' = addListToUniqDSet acc_pkgs $ map fst pkg_deps
677 --
678 if pkg /= this_pkg
679 then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toInstalledUnitId pkg))
680 else follow_deps (map (mkModule this_pkg) boot_deps' ++ mods)
681 acc_mods' acc_pkgs'
682 where
683 msg = text "need to link module" <+> ppr mod <+>
684 text "due to use of Template Haskell"
685
686
687 link_boot_mod_error mod =
688 throwGhcExceptionIO (ProgramError (showSDoc dflags (
689 text "module" <+> ppr mod <+>
690 text "cannot be linked; it is only available as a boot module")))
691
692 no_obj :: Outputable a => a -> IO b
693 no_obj mod = dieWith dflags span $
694 text "cannot find object file for module " <>
695 quotes (ppr mod) $$
696 while_linking_expr
697
698 while_linking_expr = text "while linking an interpreted expression"
699
700 -- This one is a build-system bug
701
702 get_linkable osuf mod_name -- A home-package module
703 | Just mod_info <- lookupHpt hpt mod_name
704 = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))
705 | otherwise
706 = do -- It's not in the HPT because we are in one shot mode,
707 -- so use the Finder to get a ModLocation...
708 mb_stuff <- findHomeModule hsc_env mod_name
709 case mb_stuff of
710 Found loc mod -> found loc mod
711 _ -> no_obj mod_name
712 where
713 found loc mod = do {
714 -- ...and then find the linkable for it
715 mb_lnk <- findObjectLinkableMaybe mod loc ;
716 case mb_lnk of {
717 Nothing -> no_obj mod ;
718 Just lnk -> adjust_linkable lnk
719 }}
720
721 adjust_linkable lnk
722 | Just new_osuf <- replace_osuf = do
723 new_uls <- mapM (adjust_ul new_osuf)
724 (linkableUnlinked lnk)
725 return lnk{ linkableUnlinked=new_uls }
726 | otherwise =
727 return lnk
728
729 adjust_ul new_osuf (DotO file) = do
730 MASSERT(osuf `isSuffixOf` file)
731 let file_base = fromJust (stripExtension osuf file)
732 new_file = file_base <.> new_osuf
733 ok <- doesFileExist new_file
734 if (not ok)
735 then dieWith dflags span $
736 text "cannot find object file "
737 <> quotes (text new_file) $$ while_linking_expr
738 else return (DotO new_file)
739 adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp)
740 adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp)
741 adjust_ul _ l@(BCOs {}) = return l
742
743
744
745 {- **********************************************************************
746
747 Loading a Decls statement
748
749 ********************************************************************* -}
750
751 linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO ()
752 linkDecls hsc_env span cbc@CompiledByteCode{..} = do
753 -- Initialise the linker (if it's not been done already)
754 initDynLinker hsc_env
755
756 -- Take lock for the actual work.
757 modifyPLS $ \pls0 -> do
758
759 -- Link the packages and modules required
760 (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods
761 if failed ok
762 then throwGhcExceptionIO (ProgramError "")
763 else do
764
765 -- Link the expression itself
766 let ie = plusNameEnv (itbl_env pls) bc_itbls
767 ce = closure_env pls
768
769 -- Link the necessary packages and linkables
770 new_bindings <- linkSomeBCOs hsc_env ie ce [cbc]
771 nms_fhvs <- makeForeignNamedHValueRefs hsc_env new_bindings
772 let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs
773 , itbl_env = ie }
774 return (pls2, ())
775 where
776 free_names = uniqDSetToList $
777 foldr (unionUniqDSets . bcoFreeNames) emptyUniqDSet bc_bcos
778
779 needed_mods :: [Module]
780 needed_mods = [ nameModule n | n <- free_names,
781 isExternalName n, -- Names from other modules
782 not (isWiredInName n) -- Exclude wired-in names
783 ] -- (see note below)
784 -- Exclude wired-in names because we may not have read
785 -- their interface files, so getLinkDeps will fail
786 -- All wired-in names are in the base package, which we link
787 -- by default, so we can safely ignore them here.
788
789 {- **********************************************************************
790
791 Loading a single module
792
793 ********************************************************************* -}
794
795 linkModule :: HscEnv -> Module -> IO ()
796 linkModule hsc_env mod = do
797 initDynLinker hsc_env
798 modifyPLS_ $ \pls -> do
799 (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod]
800 if (failed ok) then throwGhcExceptionIO (ProgramError "could not link module")
801 else return pls'
802
803 {- **********************************************************************
804
805 Link some linkables
806 The linkables may consist of a mixture of
807 byte-code modules and object modules
808
809 ********************************************************************* -}
810
811 linkModules :: HscEnv -> PersistentLinkerState -> [Linkable]
812 -> IO (PersistentLinkerState, SuccessFlag)
813 linkModules hsc_env pls linkables
814 = mask_ $ do -- don't want to be interrupted by ^C in here
815
816 let (objs, bcos) = partition isObjectLinkable
817 (concatMap partitionLinkable linkables)
818
819 -- Load objects first; they can't depend on BCOs
820 (pls1, ok_flag) <- dynLinkObjs hsc_env pls objs
821
822 if failed ok_flag then
823 return (pls1, Failed)
824 else do
825 pls2 <- dynLinkBCOs hsc_env pls1 bcos
826 return (pls2, Succeeded)
827
828
829 -- HACK to support f-x-dynamic in the interpreter; no other purpose
830 partitionLinkable :: Linkable -> [Linkable]
831 partitionLinkable li
832 = let li_uls = linkableUnlinked li
833 li_uls_obj = filter isObject li_uls
834 li_uls_bco = filter isInterpretable li_uls
835 in
836 case (li_uls_obj, li_uls_bco) of
837 (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj},
838 li {linkableUnlinked=li_uls_bco}]
839 _ -> [li]
840
841 findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
842 findModuleLinkable_maybe lis mod
843 = case [LM time nm us | LM time nm us <- lis, nm == mod] of
844 [] -> Nothing
845 [li] -> Just li
846 _ -> pprPanic "findModuleLinkable" (ppr mod)
847
848 linkableInSet :: Linkable -> [Linkable] -> Bool
849 linkableInSet l objs_loaded =
850 case findModuleLinkable_maybe objs_loaded (linkableModule l) of
851 Nothing -> False
852 Just m -> linkableTime l == linkableTime m
853
854
855 {- **********************************************************************
856
857 The object-code linker
858
859 ********************************************************************* -}
860
861 dynLinkObjs :: HscEnv -> PersistentLinkerState -> [Linkable]
862 -> IO (PersistentLinkerState, SuccessFlag)
863 dynLinkObjs hsc_env pls objs = do
864 -- Load the object files and link them
865 let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
866 pls1 = pls { objs_loaded = objs_loaded' }
867 unlinkeds = concatMap linkableUnlinked new_objs
868 wanted_objs = map nameOfObject unlinkeds
869
870 if interpreterDynamic (hsc_dflags hsc_env)
871 then do pls2 <- dynLoadObjs hsc_env pls1 wanted_objs
872 return (pls2, Succeeded)
873 else do mapM_ (loadObj hsc_env) wanted_objs
874
875 -- Link them all together
876 ok <- resolveObjs hsc_env
877
878 -- If resolving failed, unload all our
879 -- object modules and carry on
880 if succeeded ok then do
881 return (pls1, Succeeded)
882 else do
883 pls2 <- unload_wkr hsc_env [] pls1
884 return (pls2, Failed)
885
886
887 dynLoadObjs :: HscEnv -> PersistentLinkerState -> [FilePath]
888 -> IO PersistentLinkerState
889 dynLoadObjs _ pls [] = return pls
890 dynLoadObjs hsc_env pls objs = do
891 let dflags = hsc_dflags hsc_env
892 let platform = targetPlatform dflags
893 let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ]
894 let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ]
895 (soFile, libPath , libName) <-
896 newTempLibName dflags TFL_CurrentModule (soExt platform)
897 let
898 dflags2 = dflags {
899 -- We don't want the original ldInputs in
900 -- (they're already linked in), but we do want
901 -- to link against previous dynLoadObjs
902 -- libraries if there were any, so that the linker
903 -- can resolve dependencies when it loads this
904 -- library.
905 ldInputs =
906 concatMap
907 (\(lp, l) ->
908 [ Option ("-L" ++ lp)
909 , Option "-Xlinker"
910 , Option "-rpath"
911 , Option "-Xlinker"
912 , Option lp
913 , Option ("-l" ++ l)
914 ])
915 (temp_sos pls)
916 ++ concatMap
917 (\lp ->
918 [ Option ("-L" ++ lp)
919 , Option "-Xlinker"
920 , Option "-rpath"
921 , Option "-Xlinker"
922 , Option lp
923 ])
924 minus_big_ls
925 -- See Note [-Xlinker -rpath vs -Wl,-rpath]
926 ++ map (\l -> Option ("-l" ++ l)) minus_ls,
927 -- Add -l options and -L options from dflags.
928 --
929 -- When running TH for a non-dynamic way, we still
930 -- need to make -l flags to link against the dynamic
931 -- libraries, so we need to add WayDyn to ways.
932 --
933 -- Even if we're e.g. profiling, we still want
934 -- the vanilla dynamic libraries, so we set the
935 -- ways / build tag to be just WayDyn.
936 ways = [WayDyn],
937 buildTag = mkBuildTag [WayDyn],
938 outputFile = Just soFile
939 }
940 -- link all "loaded packages" so symbols in those can be resolved
941 -- Note: We are loading packages with local scope, so to see the
942 -- symbols in this link we must link all loaded packages again.
943 linkDynLib dflags2 objs (pkgs_loaded pls)
944
945 -- if we got this far, extend the lifetime of the library file
946 changeTempFilesLifetime dflags TFL_GhcSession [soFile]
947 m <- loadDLL hsc_env soFile
948 case m of
949 Nothing -> return pls { temp_sos = (libPath, libName) : temp_sos pls }
950 Just err -> panic ("Loading temp shared object failed: " ++ err)
951
952 rmDupLinkables :: [Linkable] -- Already loaded
953 -> [Linkable] -- New linkables
954 -> ([Linkable], -- New loaded set (including new ones)
955 [Linkable]) -- New linkables (excluding dups)
956 rmDupLinkables already ls
957 = go already [] ls
958 where
959 go already extras [] = (already, extras)
960 go already extras (l:ls)
961 | linkableInSet l already = go already extras ls
962 | otherwise = go (l:already) (l:extras) ls
963
964 {- **********************************************************************
965
966 The byte-code linker
967
968 ********************************************************************* -}
969
970
971 dynLinkBCOs :: HscEnv -> PersistentLinkerState -> [Linkable]
972 -> IO PersistentLinkerState
973 dynLinkBCOs hsc_env pls bcos = do
974
975 let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
976 pls1 = pls { bcos_loaded = bcos_loaded' }
977 unlinkeds :: [Unlinked]
978 unlinkeds = concatMap linkableUnlinked new_bcos
979
980 cbcs :: [CompiledByteCode]
981 cbcs = map byteCodeOfObject unlinkeds
982
983
984 ies = map bc_itbls cbcs
985 gce = closure_env pls
986 final_ie = foldr plusNameEnv (itbl_env pls) ies
987
988 names_and_refs <- linkSomeBCOs hsc_env final_ie gce cbcs
989
990 -- We only want to add the external ones to the ClosureEnv
991 let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs
992
993 -- Immediately release any HValueRefs we're not going to add
994 freeHValueRefs hsc_env (map snd to_drop)
995 -- Wrap finalizers on the ones we want to keep
996 new_binds <- makeForeignNamedHValueRefs hsc_env to_add
997
998 return pls1 { closure_env = extendClosureEnv gce new_binds,
999 itbl_env = final_ie }
1000
1001 -- Link a bunch of BCOs and return references to their values
1002 linkSomeBCOs :: HscEnv
1003 -> ItblEnv
1004 -> ClosureEnv
1005 -> [CompiledByteCode]
1006 -> IO [(Name,HValueRef)]
1007 -- The returned HValueRefs are associated 1-1 with
1008 -- the incoming unlinked BCOs. Each gives the
1009 -- value of the corresponding unlinked BCO
1010
1011 linkSomeBCOs hsc_env ie ce mods = foldr fun do_link mods []
1012 where
1013 fun CompiledByteCode{..} inner accum =
1014 case bc_breaks of
1015 Nothing -> inner ((panic "linkSomeBCOs: no break array", bc_bcos) : accum)
1016 Just mb -> withForeignRef (modBreaks_flags mb) $ \breakarray ->
1017 inner ((breakarray, bc_bcos) : accum)
1018
1019 do_link [] = return []
1020 do_link mods = do
1021 let flat = [ (breakarray, bco) | (breakarray, bcos) <- mods, bco <- bcos ]
1022 names = map (unlinkedBCOName . snd) flat
1023 bco_ix = mkNameEnv (zip names [0..])
1024 resolved <- sequence [ linkBCO hsc_env ie ce bco_ix breakarray bco
1025 | (breakarray, bco) <- flat ]
1026 hvrefs <- createBCOs hsc_env resolved
1027 return (zip names hvrefs)
1028
1029 -- | Useful to apply to the result of 'linkSomeBCOs'
1030 makeForeignNamedHValueRefs
1031 :: HscEnv -> [(Name,HValueRef)] -> IO [(Name,ForeignHValue)]
1032 makeForeignNamedHValueRefs hsc_env bindings =
1033 mapM (\(n, hvref) -> (n,) <$> mkFinalizedHValue hsc_env hvref) bindings
1034
1035 {- **********************************************************************
1036
1037 Unload some object modules
1038
1039 ********************************************************************* -}
1040
1041 -- ---------------------------------------------------------------------------
1042 -- | Unloading old objects ready for a new compilation sweep.
1043 --
1044 -- The compilation manager provides us with a list of linkables that it
1045 -- considers \"stable\", i.e. won't be recompiled this time around. For
1046 -- each of the modules current linked in memory,
1047 --
1048 -- * if the linkable is stable (and it's the same one -- the user may have
1049 -- recompiled the module on the side), we keep it,
1050 --
1051 -- * otherwise, we unload it.
1052 --
1053 -- * we also implicitly unload all temporary bindings at this point.
1054 --
1055 unload :: HscEnv
1056 -> [Linkable] -- ^ The linkables to *keep*.
1057 -> IO ()
1058 unload hsc_env linkables
1059 = mask_ $ do -- mask, so we're safe from Ctrl-C in here
1060
1061 -- Initialise the linker (if it's not been done already)
1062 initDynLinker hsc_env
1063
1064 new_pls
1065 <- modifyPLS $ \pls -> do
1066 pls1 <- unload_wkr hsc_env linkables pls
1067 return (pls1, pls1)
1068
1069 let dflags = hsc_dflags hsc_env
1070 debugTraceMsg dflags 3 $
1071 text "unload: retaining objs" <+> ppr (objs_loaded new_pls)
1072 debugTraceMsg dflags 3 $
1073 text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls)
1074 return ()
1075
1076 unload_wkr :: HscEnv
1077 -> [Linkable] -- stable linkables
1078 -> PersistentLinkerState
1079 -> IO PersistentLinkerState
1080 -- Does the core unload business
1081 -- (the wrapper blocks exceptions and deals with the PLS get and put)
1082
1083 unload_wkr hsc_env keep_linkables pls = do
1084 let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable keep_linkables
1085
1086 discard keep l = not (linkableInSet l keep)
1087
1088 (objs_to_unload, remaining_objs_loaded) =
1089 partition (discard objs_to_keep) (objs_loaded pls)
1090 (bcos_to_unload, remaining_bcos_loaded) =
1091 partition (discard bcos_to_keep) (bcos_loaded pls)
1092
1093 mapM_ unloadObjs objs_to_unload
1094 mapM_ unloadObjs bcos_to_unload
1095
1096 -- If we unloaded any object files at all, we need to purge the cache
1097 -- of lookupSymbol results.
1098 when (not (null (objs_to_unload ++
1099 filter (not . null . linkableObjs) bcos_to_unload))) $
1100 purgeLookupSymbolCache hsc_env
1101
1102 let bcos_retained = mkModuleSet $ map linkableModule remaining_bcos_loaded
1103
1104 -- Note that we want to remove all *local*
1105 -- (i.e. non-isExternal) names too (these are the
1106 -- temporary bindings from the command line).
1107 keep_name (n,_) = isExternalName n &&
1108 nameModule n `elemModuleSet` bcos_retained
1109
1110 itbl_env' = filterNameEnv keep_name (itbl_env pls)
1111 closure_env' = filterNameEnv keep_name (closure_env pls)
1112
1113 new_pls = pls { itbl_env = itbl_env',
1114 closure_env = closure_env',
1115 bcos_loaded = remaining_bcos_loaded,
1116 objs_loaded = remaining_objs_loaded }
1117
1118 return new_pls
1119 where
1120 unloadObjs :: Linkable -> IO ()
1121 unloadObjs lnk
1122 | dynamicGhc = return ()
1123 -- We don't do any cleanup when linking objects with the
1124 -- dynamic linker. Doing so introduces extra complexity for
1125 -- not much benefit.
1126 | otherwise
1127 = mapM_ (unloadObj hsc_env) [f | DotO f <- linkableUnlinked lnk]
1128 -- The components of a BCO linkable may contain
1129 -- dot-o files. Which is very confusing.
1130 --
1131 -- But the BCO parts can be unlinked just by
1132 -- letting go of them (plus of course depopulating
1133 -- the symbol table which is done in the main body)
1134
1135 {- **********************************************************************
1136
1137 Loading packages
1138
1139 ********************************************************************* -}
1140
1141 data LibrarySpec
1142 = Object FilePath -- Full path name of a .o file, including trailing .o
1143 -- For dynamic objects only, try to find the object
1144 -- file in all the directories specified in
1145 -- v_Library_paths before giving up.
1146
1147 | Archive FilePath -- Full path name of a .a file, including trailing .a
1148
1149 | DLL String -- "Unadorned" name of a .DLL/.so
1150 -- e.g. On unix "qt" denotes "libqt.so"
1151 -- On Windows "burble" denotes "burble.DLL" or "libburble.dll"
1152 -- loadDLL is platform-specific and adds the lib/.so/.DLL
1153 -- suffixes platform-dependently
1154
1155 | DLLPath FilePath -- Absolute or relative pathname to a dynamic library
1156 -- (ends with .dll or .so).
1157
1158 | Framework String -- Only used for darwin, but does no harm
1159
1160 -- If this package is already part of the GHCi binary, we'll already
1161 -- have the right DLLs for this package loaded, so don't try to
1162 -- load them again.
1163 --
1164 -- But on Win32 we must load them 'again'; doing so is a harmless no-op
1165 -- as far as the loader is concerned, but it does initialise the list
1166 -- of DLL handles that rts/Linker.c maintains, and that in turn is
1167 -- used by lookupSymbol. So we must call addDLL for each library
1168 -- just to get the DLL handle into the list.
1169 partOfGHCi :: [PackageName]
1170 partOfGHCi
1171 | isWindowsHost || isDarwinHost = []
1172 | otherwise = map (PackageName . mkFastString)
1173 ["base", "template-haskell", "editline"]
1174
1175 showLS :: LibrarySpec -> String
1176 showLS (Object nm) = "(static) " ++ nm
1177 showLS (Archive nm) = "(static archive) " ++ nm
1178 showLS (DLL nm) = "(dynamic) " ++ nm
1179 showLS (DLLPath nm) = "(dynamic) " ++ nm
1180 showLS (Framework nm) = "(framework) " ++ nm
1181
1182 -- TODO: Make this type more precise
1183 type LinkerUnitId = InstalledUnitId
1184
1185 -- | Link exactly the specified packages, and their dependents (unless of
1186 -- course they are already linked). The dependents are linked
1187 -- automatically, and it doesn't matter what order you specify the input
1188 -- packages.
1189 --
1190 linkPackages :: HscEnv -> [LinkerUnitId] -> IO ()
1191 -- NOTE: in fact, since each module tracks all the packages it depends on,
1192 -- we don't really need to use the package-config dependencies.
1193 --
1194 -- However we do need the package-config stuff (to find aux libs etc),
1195 -- and following them lets us load libraries in the right order, which
1196 -- perhaps makes the error message a bit more localised if we get a link
1197 -- failure. So the dependency walking code is still here.
1198
1199 linkPackages hsc_env new_pkgs = do
1200 -- It's probably not safe to try to load packages concurrently, so we take
1201 -- a lock.
1202 initDynLinker hsc_env
1203 modifyPLS_ $ \pls -> do
1204 linkPackages' hsc_env new_pkgs pls
1205
1206 linkPackages' :: HscEnv -> [LinkerUnitId] -> PersistentLinkerState
1207 -> IO PersistentLinkerState
1208 linkPackages' hsc_env new_pks pls = do
1209 pkgs' <- link (pkgs_loaded pls) new_pks
1210 return $! pls { pkgs_loaded = pkgs' }
1211 where
1212 dflags = hsc_dflags hsc_env
1213
1214 link :: [LinkerUnitId] -> [LinkerUnitId] -> IO [LinkerUnitId]
1215 link pkgs new_pkgs =
1216 foldM link_one pkgs new_pkgs
1217
1218 link_one pkgs new_pkg
1219 | new_pkg `elem` pkgs -- Already linked
1220 = return pkgs
1221
1222 | Just pkg_cfg <- lookupInstalledPackage dflags new_pkg
1223 = do { -- Link dependents first
1224 pkgs' <- link pkgs (depends pkg_cfg)
1225 -- Now link the package itself
1226 ; linkPackage hsc_env pkg_cfg
1227 ; return (new_pkg : pkgs') }
1228
1229 | otherwise
1230 = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (installedUnitIdFS new_pkg)))
1231
1232
1233 linkPackage :: HscEnv -> PackageConfig -> IO ()
1234 linkPackage hsc_env pkg
1235 = do
1236 let dflags = hsc_dflags hsc_env
1237 platform = targetPlatform dflags
1238 dirs | interpreterDynamic dflags = Packages.libraryDynDirs pkg
1239 | otherwise = Packages.libraryDirs pkg
1240
1241 let hs_libs = Packages.hsLibraries pkg
1242 -- The FFI GHCi import lib isn't needed as
1243 -- compiler/ghci/Linker.hs + rts/Linker.c link the
1244 -- interpreted references to FFI to the compiled FFI.
1245 -- We therefore filter it out so that we don't get
1246 -- duplicate symbol errors.
1247 hs_libs' = filter ("HSffi" /=) hs_libs
1248
1249 -- Because of slight differences between the GHC dynamic linker and
1250 -- the native system linker some packages have to link with a
1251 -- different list of libraries when using GHCi. Examples include: libs
1252 -- that are actually gnu ld scripts, and the possibility that the .a
1253 -- libs do not exactly match the .so/.dll equivalents. So if the
1254 -- package file provides an "extra-ghci-libraries" field then we use
1255 -- that instead of the "extra-libraries" field.
1256 extra_libs =
1257 (if null (Packages.extraGHCiLibraries pkg)
1258 then Packages.extraLibraries pkg
1259 else Packages.extraGHCiLibraries pkg)
1260 ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ]
1261 -- See Note [Fork/Exec Windows]
1262 gcc_paths <- getGCCPaths dflags (platformOS platform)
1263
1264 hs_classifieds
1265 <- mapM (locateLib hsc_env True dirs gcc_paths) hs_libs'
1266 extra_classifieds
1267 <- mapM (locateLib hsc_env False dirs gcc_paths) extra_libs
1268 let classifieds = hs_classifieds ++ extra_classifieds
1269
1270 -- Complication: all the .so's must be loaded before any of the .o's.
1271 let known_dlls = [ dll | DLLPath dll <- classifieds ]
1272 dlls = [ dll | DLL dll <- classifieds ]
1273 objs = [ obj | Object obj <- classifieds ]
1274 archs = [ arch | Archive arch <- classifieds ]
1275
1276 -- Add directories to library search paths
1277 let dll_paths = map takeDirectory known_dlls
1278 all_paths = nub $ map normalise $ dll_paths ++ dirs
1279 pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths
1280
1281 maybePutStr dflags
1282 ("Loading package " ++ sourcePackageIdString pkg ++ " ... ")
1283
1284 -- See comments with partOfGHCi
1285 when (packageName pkg `notElem` partOfGHCi) $ do
1286 loadFrameworks hsc_env platform pkg
1287 mapM_ (load_dyn hsc_env)
1288 (known_dlls ++ map (mkSOName platform) dlls)
1289
1290 -- After loading all the DLLs, we can load the static objects.
1291 -- Ordering isn't important here, because we do one final link
1292 -- step to resolve everything.
1293 mapM_ (loadObj hsc_env) objs
1294 mapM_ (loadArchive hsc_env) archs
1295
1296 maybePutStr dflags "linking ... "
1297 ok <- resolveObjs hsc_env
1298
1299 -- DLLs are loaded, reset the search paths
1300 -- Import libraries will be loaded via loadArchive so only
1301 -- reset the DLL search path after all archives are loaded
1302 -- as well.
1303 mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache
1304
1305 if succeeded ok
1306 then maybePutStrLn dflags "done."
1307 else let errmsg = "unable to load package `"
1308 ++ sourcePackageIdString pkg ++ "'"
1309 in throwGhcExceptionIO (InstallationError errmsg)
1310
1311 -- we have already searched the filesystem; the strings passed to load_dyn
1312 -- can be passed directly to loadDLL. They are either fully-qualified
1313 -- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so"). In the latter case,
1314 -- loadDLL is going to search the system paths to find the library.
1315 --
1316 load_dyn :: HscEnv -> FilePath -> IO ()
1317 load_dyn hsc_env dll = do
1318 r <- loadDLL hsc_env dll
1319 case r of
1320 Nothing -> return ()
1321 Just err -> throwGhcExceptionIO (CmdLineError ("can't load .so/.DLL for: "
1322 ++ dll ++ " (" ++ err ++ ")" ))
1323
1324 loadFrameworks :: HscEnv -> Platform -> PackageConfig -> IO ()
1325 loadFrameworks hsc_env platform pkg
1326 = when (platformUsesFrameworks platform) $ mapM_ load frameworks
1327 where
1328 fw_dirs = Packages.frameworkDirs pkg
1329 frameworks = Packages.frameworks pkg
1330
1331 load fw = do r <- loadFramework hsc_env fw_dirs fw
1332 case r of
1333 Nothing -> return ()
1334 Just err -> throwGhcExceptionIO (CmdLineError ("can't load framework: "
1335 ++ fw ++ " (" ++ err ++ ")" ))
1336
1337 -- Try to find an object file for a given library in the given paths.
1338 -- If it isn't present, we assume that addDLL in the RTS can find it,
1339 -- which generally means that it should be a dynamic library in the
1340 -- standard system search path.
1341 -- For GHCi we tend to prefer dynamic libraries over static ones as
1342 -- they are easier to load and manage, have less overhead.
1343 locateLib :: HscEnv -> Bool -> [FilePath] -> [FilePath] -> String
1344 -> IO LibrarySpec
1345 locateLib hsc_env is_hs lib_dirs gcc_dirs lib
1346 | not is_hs
1347 -- For non-Haskell libraries (e.g. gmp, iconv):
1348 -- first look in library-dirs for a dynamic library (on User paths only)
1349 -- (libfoo.so)
1350 -- then try looking for import libraries on Windows (on User paths only)
1351 -- (.dll.a, .lib)
1352 -- first look in library-dirs for a dynamic library (on GCC paths only)
1353 -- (libfoo.so)
1354 -- then check for system dynamic libraries (e.g. kernel32.dll on windows)
1355 -- then try looking for import libraries on Windows (on GCC paths only)
1356 -- (.dll.a, .lib)
1357 -- then look in library-dirs for a static library (libfoo.a)
1358 -- then look in library-dirs and inplace GCC for a dynamic library (libfoo.so)
1359 -- then try looking for import libraries on Windows (.dll.a, .lib)
1360 -- then look in library-dirs and inplace GCC for a static library (libfoo.a)
1361 -- then try "gcc --print-file-name" to search gcc's search path
1362 -- for a dynamic library (#5289)
1363 -- otherwise, assume loadDLL can find it
1364 --
1365 -- The logic is a bit complicated, but the rationale behind it is that
1366 -- loading a shared library for us is O(1) while loading an archive is
1367 -- O(n). Loading an import library is also O(n) so in general we prefer
1368 -- shared libraries because they are simpler and faster.
1369 --
1370 = findDll user `orElse`
1371 tryImpLib user `orElse`
1372 findDll gcc `orElse`
1373 findSysDll `orElse`
1374 tryImpLib gcc `orElse`
1375 findArchive `orElse`
1376 tryGcc `orElse`
1377 assumeDll
1378
1379 | loading_dynamic_hs_libs -- search for .so libraries first.
1380 = findHSDll `orElse`
1381 findDynObject `orElse`
1382 assumeDll
1383
1384 | loading_profiled_hs_libs -- only a libHSfoo_p.a archive will do.
1385 = findArchive `orElse`
1386 assumeDll
1387
1388 | otherwise
1389 -- HSfoo.o is the best, but only works for the normal way
1390 -- libHSfoo.a is the backup option.
1391 = findObject `orElse`
1392 findArchive `orElse`
1393 assumeDll
1394
1395 where
1396 dflags = hsc_dflags hsc_env
1397 dirs = lib_dirs ++ gcc_dirs
1398 gcc = False
1399 user = True
1400
1401 obj_file = lib <.> "o"
1402 dyn_obj_file = lib <.> "dyn_o"
1403 arch_files = [ "lib" ++ lib ++ lib_tag <.> "a"
1404 , lib <.> "a" -- native code has no lib_tag
1405 , "lib" ++ lib, lib
1406 ]
1407 lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else ""
1408
1409 loading_profiled_hs_libs = interpreterProfiled dflags
1410 loading_dynamic_hs_libs = interpreterDynamic dflags
1411
1412 import_libs = [ lib <.> "lib" , "lib" ++ lib <.> "lib"
1413 , "lib" ++ lib <.> "dll.a", lib <.> "dll.a"
1414 ]
1415
1416 hs_dyn_lib_name = lib ++ '-':programName dflags ++ projectVersion dflags
1417 hs_dyn_lib_file = mkHsSOName platform hs_dyn_lib_name
1418
1419 so_name = mkSOName platform lib
1420 lib_so_name = "lib" ++ so_name
1421 dyn_lib_file = case (arch, os) of
1422 (ArchX86_64, OSSolaris2) -> "64" </> so_name
1423 _ -> so_name
1424
1425 findObject = liftM (fmap Object) $ findFile dirs obj_file
1426 findDynObject = liftM (fmap Object) $ findFile dirs dyn_obj_file
1427 findArchive = let local name = liftM (fmap Archive) $ findFile dirs name
1428 in apply (map local arch_files)
1429 findHSDll = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file
1430 findDll re = let dirs' = if re == user then lib_dirs else gcc_dirs
1431 in liftM (fmap DLLPath) $ findFile dirs' dyn_lib_file
1432 findSysDll = fmap (fmap $ DLL . dropExtension . takeFileName) $
1433 findSystemLibrary hsc_env so_name
1434 tryGcc = let search = searchForLibUsingGcc dflags
1435 dllpath = liftM (fmap DLLPath)
1436 short = dllpath $ search so_name lib_dirs
1437 full = dllpath $ search lib_so_name lib_dirs
1438 gcc name = liftM (fmap Archive) $ search name lib_dirs
1439 files = import_libs ++ arch_files
1440 in apply $ short : full : map gcc files
1441 tryImpLib re = case os of
1442 OSMinGW32 ->
1443 let dirs' = if re == user then lib_dirs else gcc_dirs
1444 implib name = liftM (fmap Archive) $
1445 findFile dirs' name
1446 in apply (map implib import_libs)
1447 _ -> return Nothing
1448
1449 assumeDll = return (DLL lib)
1450 infixr `orElse`
1451 f `orElse` g = f >>= maybe g return
1452
1453 apply [] = return Nothing
1454 apply (x:xs) = do x' <- x
1455 if isJust x'
1456 then return x'
1457 else apply xs
1458
1459 platform = targetPlatform dflags
1460 arch = platformArch platform
1461 os = platformOS platform
1462
1463 searchForLibUsingGcc :: DynFlags -> String -> [FilePath] -> IO (Maybe FilePath)
1464 searchForLibUsingGcc dflags so dirs = do
1465 -- GCC does not seem to extend the library search path (using -L) when using
1466 -- --print-file-name. So instead pass it a new base location.
1467 str <- askLd dflags (map (FileOption "-B") dirs
1468 ++ [Option "--print-file-name", Option so])
1469 let file = case lines str of
1470 [] -> ""
1471 l:_ -> l
1472 if (file == so)
1473 then return Nothing
1474 else return (Just file)
1475
1476 -- | Retrieve the list of search directory GCC and the System use to find
1477 -- libraries and components. See Note [Fork/Exec Windows].
1478 getGCCPaths :: DynFlags -> OS -> IO [FilePath]
1479 getGCCPaths dflags os
1480 = case os of
1481 OSMinGW32 ->
1482 do gcc_dirs <- getGccSearchDirectory dflags "libraries"
1483 sys_dirs <- getSystemDirectories
1484 return $ nub $ gcc_dirs ++ sys_dirs
1485 _ -> return []
1486
1487 -- | Cache for the GCC search directories as this can't easily change
1488 -- during an invocation of GHC. (Maybe with some env. variable but we'll)
1489 -- deal with that highly unlikely scenario then.
1490 {-# NOINLINE gccSearchDirCache #-}
1491 gccSearchDirCache :: IORef [(String, [String])]
1492 gccSearchDirCache = unsafePerformIO $ newIORef []
1493
1494 -- Note [Fork/Exec Windows]
1495 -- ~~~~~~~~~~~~~~~~~~~~~~~~
1496 -- fork/exec is expensive on Windows, for each time we ask GCC for a library we
1497 -- have to eat the cost of af least 3 of these: gcc -> real_gcc -> cc1.
1498 -- So instead get a list of location that GCC would search and use findDirs
1499 -- which hopefully is written in an optimized mannor to take advantage of
1500 -- caching. At the very least we remove the overhead of the fork/exec and waits
1501 -- which dominate a large percentage of startup time on Windows.
1502 getGccSearchDirectory :: DynFlags -> String -> IO [FilePath]
1503 getGccSearchDirectory dflags key = do
1504 cache <- readIORef gccSearchDirCache
1505 case lookup key cache of
1506 Just x -> return x
1507 Nothing -> do
1508 str <- askLd dflags [Option "--print-search-dirs"]
1509 let line = dropWhile isSpace str
1510 name = key ++ ": ="
1511 if null line
1512 then return []
1513 else do let val = split $ find name line
1514 dirs <- filterM doesDirectoryExist val
1515 modifyIORef' gccSearchDirCache ((key, dirs):)
1516 return val
1517 where split :: FilePath -> [FilePath]
1518 split r = case break (==';') r of
1519 (s, [] ) -> [s]
1520 (s, (_:xs)) -> s : split xs
1521
1522 find :: String -> String -> String
1523 find r x = let lst = lines x
1524 val = filter (r `isPrefixOf`) lst
1525 in if null val
1526 then []
1527 else case break (=='=') (head val) of
1528 (_ , []) -> []
1529 (_, (_:xs)) -> xs
1530
1531 -- | Get a list of system search directories, this to alleviate pressure on
1532 -- the findSysDll function.
1533 getSystemDirectories :: IO [FilePath]
1534 #if defined(mingw32_HOST_OS)
1535 getSystemDirectories = fmap (:[]) getSystemDirectory
1536 #else
1537 getSystemDirectories = return []
1538 #endif
1539
1540 -- ----------------------------------------------------------------------------
1541 -- Loading a dynamic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
1542
1543 -- Darwin / MacOS X only: load a framework
1544 -- a framework is a dynamic library packaged inside a directory of the same
1545 -- name. They are searched for in different paths than normal libraries.
1546 loadFramework :: HscEnv -> [FilePath] -> FilePath -> IO (Maybe String)
1547 loadFramework hsc_env extraPaths rootname
1548 = do { either_dir <- tryIO getHomeDirectory
1549 ; let homeFrameworkPath = case either_dir of
1550 Left _ -> []
1551 Right dir -> [dir </> "Library/Frameworks"]
1552 ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths
1553 ; mb_fwk <- findFile ps fwk_file
1554 ; case mb_fwk of
1555 Just fwk_path -> loadDLL hsc_env fwk_path
1556 Nothing -> return (Just "not found") }
1557 -- Tried all our known library paths, but dlopen()
1558 -- has no built-in paths for frameworks: give up
1559 where
1560 fwk_file = rootname <.> "framework" </> rootname
1561 -- sorry for the hardcoded paths, I hope they won't change anytime soon:
1562 defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
1563
1564 {- **********************************************************************
1565
1566 Helper functions
1567
1568 ********************************************************************* -}
1569
1570 maybePutStr :: DynFlags -> String -> IO ()
1571 maybePutStr dflags s
1572 = when (verbosity dflags > 1) $
1573 putLogMsg dflags
1574 NoReason
1575 SevInteractive
1576 noSrcSpan
1577 (defaultUserStyle dflags)
1578 (text s)
1579
1580 maybePutStrLn :: DynFlags -> String -> IO ()
1581 maybePutStrLn dflags s = maybePutStr dflags (s ++ "\n")