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