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