compiler/ghci/Linker.lhs

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