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