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