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