compiler/ghci/Linker.lhs

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