compiler/ghci/Linker.lhs

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