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