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