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