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