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