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