compiler/ghci/Linker.lhs

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