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