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