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