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