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