compiler/ghci/Linker.lhs

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