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