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