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