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