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