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