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