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