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