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