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