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