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