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