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