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