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