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