ghc/compiler/ghci/Linker.lhs

   1 %
   2 % (c) The University of Glasgow 2000
   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
  16 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
  17
  18 module Linker ( HValue, initLinker, showLinkerState,
  19                 linkPackages, linkLibraries,
  20                 linkModules, unload, extendLinkEnv, linkExpr,
  21                 LibrarySpec(..)
  22         ) where
  23
  24 #include "../includes/config.h"
  25 #include "HsVersions.h"
  26
  27 import ObjLink          ( loadDLL, loadObj, unloadObj, resolveObjs, initLinker )
  28 import ByteCodeLink     ( HValue, ClosureEnv, extendClosureEnv, linkBCO )
  29 import ByteCodeItbls    ( ItblEnv )
  30 import ByteCodeAsm      ( CompiledByteCode(..), bcosFreeNames,
  31                           UnlinkedBCO, UnlinkedBCOExpr, nameOfUnlinkedBCO )
  32
  33 import Packages         ( PackageConfig(..), PackageName, PackageConfigMap, lookupPkg,
  34                           packageDependents, packageNameString )
  35 import DriverState      ( v_Library_paths, v_Cmdline_libraries, getPackageConfigMap )
  36
  37 import HscTypes         ( Linkable(..), isObjectLinkable, nameOfObject, byteCodeOfObject,
  38                           Unlinked(..), isInterpretable, isObject,
  39                           HscEnv(..), PersistentCompilerState(..), ExternalPackageState(..),
  40                           HomePackageTable, PackageIfaceTable, ModIface(..), HomeModInfo(..) )
  41 import Name             ( Name,  nameModule, isExternalName )
  42 import NameEnv
  43 import NameSet          ( nameSetToList )
  44 import Module           ( Module, ModuleName, moduleName, lookupModuleEnvByName )
  45 import FastString       ( FastString(..), unpackFS )
  46 import CmdLineOpts      ( DynFlags(verbosity) )
  47 import BasicTypes       ( SuccessFlag(..), succeeded, failed )
  48 import Outputable
  49 import Panic            ( GhcException(..) )
  50 import Util             ( zipLazy, global )
  51 import ErrUtils         ( Message )
  52
  53 -- Standard libraries
  54 import Control.Monad    ( when, filterM, foldM )
  55
  56 import Data.IORef       ( IORef, readIORef, writeIORef )
  57 import Data.List        ( partition )
  58
  59 import System.IO        ( putStr, putStrLn, hPutStrLn, stderr, fixIO )
  60 import System.Directory ( doesFileExist )
  61
  62 import Control.Exception ( block, throwDyn )
  63
  64 #if __GLASGOW_HASKELL__ >= 503
  65 import GHC.IOBase       ( IO(..) )
  66 #else
  67 import PrelIOBase       ( IO(..) )
  68 #endif
  69 \end{code}
  70
  71
  72 %************************************************************************
  73 %*                                                                      *
  74                         The Linker's state
  75 %*                                                                      *
  76 %************************************************************************
  77
  78 The persistent linker state *must* match the actual state of the
  79 C dynamic linker at all times, so we keep it in a private global variable.
  80
  81
  82 The PersistentLinkerState maps Names to actual closures (for
  83 interpreted code only), for use during linking.
  84
  85 \begin{code}
  86 GLOBAL_VAR(v_PersistentLinkerState, emptyPLS, PersistentLinkerState)
  87
  88 data PersistentLinkerState
  89    = PersistentLinkerState {
  90
  91         -- Current global mapping from Names to their true values
  92         closure_env :: ClosureEnv,
  93
  94         -- The current global mapping from RdrNames of DataCons to
  95         -- info table addresses.
  96         -- When a new Unlinked is linked into the running image, or an existing
  97         -- module in the image is replaced, the itbl_env must be updated
  98         -- appropriately.
  99         itbl_env    :: ItblEnv,
 100
 101         -- The currently loaded interpreted modules (home package)
 102         bcos_loaded :: [Linkable],
 103
 104         -- And the currently-loaded compiled modules (home package)
 105         objs_loaded :: [Linkable],
 106
 107         -- The currently-loaded packages; always object code
 108         -- Held, as usual, in dependency order; though I am not sure if
 109         -- that is really important
 110         pkgs_loaded :: [PackageName]
 111      }
 112
 113 emptyPLS :: PersistentLinkerState
 114 emptyPLS = PersistentLinkerState { closure_env = emptyNameEnv,
 115                                    itbl_env    = emptyNameEnv,
 116                                    pkgs_loaded = init_pkgs_loaded,
 117                                    bcos_loaded = [],
 118                                    objs_loaded = [] }
 119
 120 -- Packages that don't need loading, because the compiler
 121 -- shares them with the interpreted program.
 122 init_pkgs_loaded = [ FSLIT("rts") ]
 123 \end{code}
 124
 125 \begin{code}
 126 extendLinkEnv :: [(Name,HValue)] -> IO ()
 127 -- Automatically discards shadowed bindings
 128 extendLinkEnv new_bindings
 129   = do  pls <- readIORef v_PersistentLinkerState
 130         let new_closure_env = extendClosureEnv (closure_env pls) new_bindings
 131             new_pls = pls { closure_env = new_closure_env }
 132         writeIORef v_PersistentLinkerState new_pls
 133
 134 -- filterNameMap removes from the environment all entries except
 135 --      those for a given set of modules;
 136 -- Note that this removes all *local* (i.e. non-isExternal) names too
 137 --      (these are the temporary bindings from the command line).
 138 -- Used to filter both the ClosureEnv and ItblEnv
 139
 140 filterNameMap :: [ModuleName] -> NameEnv (Name, a) -> NameEnv (Name, a)
 141 filterNameMap mods env
 142    = filterNameEnv keep_elt env
 143    where
 144      keep_elt (n,_) = isExternalName n
 145                       && (moduleName (nameModule n) `elem` mods)
 146 \end{code}
 147
 148
 149 \begin{code}
 150 showLinkerState :: IO ()
 151 -- Display the persistent linker state
 152 showLinkerState
 153   = do pls <- readIORef v_PersistentLinkerState
 154        printDump (vcat [text "----- Linker state -----",
 155                         text "Pkgs:" <+> ppr (pkgs_loaded pls),
 156                         text "Objs:" <+> ppr (objs_loaded pls),
 157                         text "BCOs:" <+> ppr (bcos_loaded pls)])
 158 \end{code}
 159
 160
 161
 162 %************************************************************************
 163 %*                                                                      *
 164                 Link a byte-code expression
 165 %*                                                                      *
 166 %************************************************************************
 167
 168 \begin{code}
 169 linkExpr :: HscEnv -> PersistentCompilerState
 170          -> UnlinkedBCOExpr -> IO HValue          -- IO BCO# really
 171
 172 -- Link a single expression, *including* first linking packages and
 173 -- modules that this expression depends on.
 174 --
 175 -- Raises an IO exception if it can't find a compiled version of the
 176 -- dependents to link.
 177
 178 linkExpr hsc_env pcs (root_ul_bco, aux_ul_bcos)
 179    =    -- Find what packages and linkables are required
 180      case getLinkDeps hpt pit needed_mods of {
 181         Left msg -> dieWith (msg $$ ptext SLIT("When linking an expression")) ;
 182         Right (lnks, pkgs) -> do {
 183
 184      linkPackages dflags pkgs
 185    ; ok <-  linkModules dflags lnks
 186    ; if failed ok then
 187         dieWith empty
 188      else do {
 189
 190         -- Link the expression itself
 191      pls <- readIORef v_PersistentLinkerState
 192    ; let ie = itbl_env pls
 193          ce = closure_env pls
 194
 195         -- Link the necessary packages and linkables
 196    ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce all_bcos
 197    ; return root_hval
 198    }}}
 199    where
 200      pit    = eps_PIT (pcs_EPS pcs)
 201      hpt    = hsc_HPT hsc_env
 202      dflags = hsc_dflags hsc_env
 203      all_bcos   = root_ul_bco : aux_ul_bcos
 204      free_names = nameSetToList (bcosFreeNames all_bcos)
 205
 206      needed_mods :: [Module]
 207      needed_mods = [ nameModule n | n <- free_names, isExternalName n ]
 208
 209 dieWith msg = throwDyn (UsageError (showSDoc msg))
 210
 211 getLinkDeps :: HomePackageTable -> PackageIfaceTable
 212             -> [Module]                                 -- If you need these
 213             -> Either Message
 214                       ([Linkable], [PackageName])       -- ... then link these first
 215
 216 -- Find all the packages and linkables that a set of modules depends on
 217
 218 getLinkDeps hpt pit mods
 219   = go []       -- Linkables so far
 220        []       -- Packages so far
 221        []       -- Modules dealt with
 222        (map moduleName mods)    -- The usage info that we use for
 223                                 -- dependencies has ModuleNames not Modules
 224   where
 225      go lnks pkgs _         [] = Right (lnks,pkgs)
 226      go lnks pkgs mods_done (mod:mods)
 227         | mod `elem` mods_done
 228         =       -- Already dealt with
 229           go lnks pkgs mods_done mods
 230
 231         | Just mod_info <- lookupModuleEnvByName hpt mod
 232         =       -- OK, so it's a home module
 233           let
 234              mod_deps = [m | (m,_,_,_) <- mi_usages (hm_iface mod_info)]
 235                 -- Get the modules that this one depends on
 236           in
 237           go (hm_linkable mod_info : lnks) pkgs (mod : mods_done) (mod_deps ++ mods)
 238
 239         | Just pkg_iface <- lookupModuleEnvByName pit mod
 240         =       -- It's a package module, so add it to the package list
 241           let
 242              pkg_name = mi_package pkg_iface
 243              pkgs' | pkg_name `elem` pkgs = pkgs
 244                    | otherwise            = pkg_name : pkgs
 245           in
 246           go lnks pkgs' (mod : mods_done) mods
 247
 248         | otherwise
 249         =       -- Not in either table
 250           Left (ptext SLIT("Can't find compiled code for dependent module") <+> ppr mod)
 251 \end{code}
 252
 253
 254 %************************************************************************
 255 %*                                                                      *
 256                 Link some linkables
 257         The linkables may consist of a mixture of
 258         byte-code modules and object modules
 259 %*                                                                      *
 260 %************************************************************************
 261
 262 \begin{code}
 263 linkModules :: DynFlags -> [Linkable] -> IO SuccessFlag
 264 linkModules dflags linkables
 265   = block $ do  -- don't want to be interrupted by ^C in here
 266
 267         let (objs, bcos) = partition isObjectLinkable
 268                               (concatMap partitionLinkable linkables)
 269
 270                 -- Load objects first; they can't depend on BCOs
 271         ok_flag <- dynLinkObjs dflags objs
 272
 273         if failed ok_flag then
 274                 return Failed
 275           else do
 276                 dynLinkBCOs bcos
 277                 return Succeeded
 278
 279
 280 -- HACK to support f-x-dynamic in the interpreter; no other purpose
 281 partitionLinkable :: Linkable -> [Linkable]
 282 partitionLinkable li
 283    = let li_uls = linkableUnlinked li
 284          li_uls_obj = filter isObject li_uls
 285          li_uls_bco = filter isInterpretable li_uls
 286      in
 287          case (li_uls_obj, li_uls_bco) of
 288             (objs@(_:_), bcos@(_:_))
 289                -> [li{linkableUnlinked=li_uls_obj}, li{linkableUnlinked=li_uls_bco}]
 290             other
 291                -> [li]
 292
 293 findModuleLinkable_maybe :: [Linkable] -> ModuleName -> Maybe Linkable
 294 findModuleLinkable_maybe lis mod
 295    = case [LM time nm us | LM time nm us <- lis, nm == mod] of
 296         []   -> Nothing
 297         [li] -> Just li
 298         many -> pprPanic "findModuleLinkable" (ppr mod)
 299
 300 filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] -> [Linkable]
 301 filterModuleLinkables p ls = filter (p . linkableModName) ls
 302
 303 linkableInSet :: Linkable -> [Linkable] -> Bool
 304 linkableInSet l objs_loaded =
 305   case findModuleLinkable_maybe objs_loaded (linkableModName l) of
 306         Nothing -> False
 307         Just m  -> linkableTime l == linkableTime m
 308 \end{code}
 309
 310
 311 %************************************************************************
 312 %*                                                                      *
 313 \subsection{The object-code linker}
 314 %*                                                                      *
 315 %************************************************************************
 316
 317 \begin{code}
 318 dynLinkObjs :: DynFlags -> [Linkable] -> IO SuccessFlag
 319         -- Side-effects the PersistentLinkerState
 320
 321 dynLinkObjs dflags objs
 322   = do  pls <- readIORef v_PersistentLinkerState
 323
 324         -- Load the object files and link them
 325         let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
 326             pls1                     = pls { objs_loaded = objs_loaded' }
 327             unlinkeds                = concatMap linkableUnlinked new_objs
 328
 329         mapM loadObj (map nameOfObject unlinkeds)
 330
 331         -- Link the all together
 332         ok <- resolveObjs
 333
 334         -- If resolving failed, unload all our
 335         -- object modules and carry on
 336         if succeeded ok then do
 337                 writeIORef v_PersistentLinkerState pls1
 338                 return Succeeded
 339           else do
 340                 pls2 <- unload_wkr dflags [] pls1
 341                 writeIORef v_PersistentLinkerState pls2
 342                 return Failed
 343
 344
 345 rmDupLinkables :: [Linkable]    -- Already loaded
 346                -> [Linkable]    -- New linkables
 347                -> ([Linkable],  -- New loaded set (including new ones)
 348                    [Linkable])  -- New linkables (excluding dups)
 349 rmDupLinkables already ls
 350   = go already [] ls
 351   where
 352     go already extras [] = (already, extras)
 353     go already extras (l:ls)
 354         | linkableInSet l already = go already     extras     ls
 355         | otherwise               = go (l:already) (l:extras) ls
 356 \end{code}
 357
 358
 359 \begin{code}
 360 linkLibraries :: DynFlags
 361               -> [String]       -- foo.o files specified on command line
 362               -> IO ()
 363 -- Used just at initialisation time to link in libraries
 364 -- specified on the command line.
 365 linkLibraries dflags objs
 366    = do { lib_paths <- readIORef v_Library_paths
 367         ; minus_ls  <- readIORef v_Cmdline_libraries
 368         ; let cmdline_lib_specs = map Object objs ++ map DLL minus_ls
 369
 370         ; if (null cmdline_lib_specs) then return ()
 371           else do {
 372
 373                 -- Now link them
 374         ; mapM_ (preloadLib dflags lib_paths) cmdline_lib_specs
 375
 376         ; maybePutStr dflags "final link ... "
 377         ; ok <- resolveObjs
 378         ; if succeeded ok then maybePutStrLn dflags "done."
 379           else throwDyn (InstallationError "linking extra libraries/objects failed")
 380         }}
 381      where
 382         preloadLib :: DynFlags -> [String] -> LibrarySpec -> IO ()
 383         preloadLib dflags lib_paths lib_spec
 384            = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
 385                 case lib_spec of
 386                    Object static_ish
 387                       -> do b <- preload_static lib_paths static_ish
 388                             maybePutStrLn dflags (if b  then "done."
 389                                                         else "not found")
 390                    DLL dll_unadorned
 391                       -> do maybe_errstr <- loadDynamic lib_paths dll_unadorned
 392                             case maybe_errstr of
 393                                Nothing -> return ()
 394                                Just mm -> preloadFailed mm lib_paths lib_spec
 395                             maybePutStrLn dflags "done"
 396
 397         preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
 398         preloadFailed sys_errmsg paths spec
 399            = do maybePutStr dflags
 400                        ("failed.\nDynamic linker error message was:\n   "
 401                         ++ sys_errmsg  ++ "\nWhilst trying to load:  "
 402                         ++ showLS spec ++ "\nDirectories to search are:\n"
 403                         ++ unlines (map ("   "++) paths) )
 404                 give_up
 405
 406         -- not interested in the paths in the static case.
 407         preload_static paths name
 408            = do b <- doesFileExist name
 409                 if not b then return False
 410                          else loadObj name >> return True
 411
 412         give_up
 413            = (throwDyn . CmdLineError)
 414                 "user specified .o/.so/.DLL could not be loaded."
 415 \end{code}
 416
 417
 418 %************************************************************************
 419 %*                                                                      *
 420 \subsection{The byte-code linker}
 421 %*                                                                      *
 422 %************************************************************************
 423
 424 \begin{code}
 425 dynLinkBCOs :: [Linkable] -> IO ()
 426         -- Side-effects the persistent linker state
 427 dynLinkBCOs bcos
 428   = do  pls <- readIORef v_PersistentLinkerState
 429
 430         let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
 431             pls1                     = pls { bcos_loaded = bcos_loaded' }
 432             unlinkeds :: [Unlinked]
 433             unlinkeds                = concatMap linkableUnlinked new_bcos
 434
 435             cbcs :: [CompiledByteCode]
 436             cbcs      = map byteCodeOfObject unlinkeds
 437
 438
 439             ul_bcos    = [b | ByteCode bs _  <- cbcs, b <- bs]
 440             ies        = [ie | ByteCode _ ie <- cbcs]
 441             gce       = closure_env pls
 442             final_ie  = foldr plusNameEnv (itbl_env pls) ies
 443
 444         (final_gce, linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos
 445                 -- What happens to these linked_bcos?
 446
 447         let pls2 = pls1 { closure_env = final_gce,
 448                           itbl_env    = final_ie }
 449
 450         writeIORef v_PersistentLinkerState pls2
 451         return ()
 452
 453 -- Link a bunch of BCOs and return them + updated closure env.
 454 linkSomeBCOs :: Bool    -- False <=> add _all_ BCOs to returned closure env
 455                         -- True  <=> add only toplevel BCOs to closure env
 456              -> ItblEnv
 457              -> ClosureEnv
 458              -> [UnlinkedBCO]
 459              -> IO (ClosureEnv, [HValue])
 460                         -- The returned HValues are associated 1-1 with
 461                         -- the incoming unlinked BCOs.  Each gives the
 462                         -- value of the corresponding unlinked BCO
 463
 464
 465 linkSomeBCOs toplevs_only ie ce_in ul_bcos
 466    = do let nms = map nameOfUnlinkedBCO ul_bcos
 467         hvals <- fixIO
 468                     ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
 469                                in  mapM (linkBCO ie ce_out) ul_bcos )
 470
 471         let ce_all_additions = zip nms hvals
 472             ce_top_additions = filter (isExternalName.fst) ce_all_additions
 473             ce_additions     = if toplevs_only then ce_top_additions
 474                                                else ce_all_additions
 475             ce_out = -- make sure we're not inserting duplicate names into the
 476                      -- closure environment, which leads to trouble.
 477                      ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions))
 478                      extendClosureEnv ce_in ce_additions
 479         return (ce_out, hvals)
 480
 481 \end{code}
 482
 483
 484 %************************************************************************
 485 %*                                                                      *
 486                 Unload some object modules
 487 %*                                                                      *
 488 %************************************************************************
 489
 490 \begin{code}
 491 -- ---------------------------------------------------------------------------
 492 -- Unloading old objects ready for a new compilation sweep.
 493 --
 494 -- The compilation manager provides us with a list of linkables that it
 495 -- considers "stable", i.e. won't be recompiled this time around.  For
 496 -- each of the modules current linked in memory,
 497 --
 498 --      * if the linkable is stable (and it's the same one - the
 499 --        user may have recompiled the module on the side), we keep it,
 500 --
 501 --      * otherwise, we unload it.
 502 --
 503 --      * we also implicitly unload all temporary bindings at this point.
 504
 505 unload :: DynFlags -> [Linkable] -> IO ()
 506 -- The 'linkables' are the ones to *keep*
 507
 508 unload dflags linkables
 509   = block $ do -- block, so we're safe from Ctrl-C in here
 510
 511         pls     <- readIORef v_PersistentLinkerState
 512         new_pls <- unload_wkr dflags linkables pls
 513         writeIORef v_PersistentLinkerState new_pls
 514
 515         let verb = verbosity dflags
 516         when (verb >= 3) $ do
 517             hPutStrLn stderr (showSDoc
 518                 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls)))
 519             hPutStrLn stderr (showSDoc
 520                 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls)))
 521
 522         return ()
 523
 524 unload_wkr :: DynFlags
 525            -> [Linkable]                -- stable linkables
 526            -> PersistentLinkerState
 527            -> IO PersistentLinkerState
 528 -- Does the core unload business
 529 -- (the wrapper blocks exceptions and deals with the PLS get and put)
 530
 531 unload_wkr dflags linkables pls
 532   = do  let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
 533
 534         objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls)
 535         bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)
 536
 537         let objs_retained = map linkableModName objs_loaded'
 538             bcos_retained = map linkableModName bcos_loaded'
 539             itbl_env'     = filterNameMap bcos_retained (itbl_env pls)
 540             closure_env'  = filterNameMap bcos_retained (closure_env pls)
 541             new_pls = pls { itbl_env = itbl_env',
 542                             closure_env = closure_env',
 543                             bcos_loaded = bcos_loaded',
 544                             objs_loaded = objs_loaded' }
 545
 546         return new_pls
 547   where
 548     maybeUnload :: [Linkable] -> Linkable -> IO Bool
 549     maybeUnload keep_linkables lnk
 550       | linkableInSet lnk linkables = return True
 551       | otherwise
 552       = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk]
 553                 -- The components of a BCO linkable may contain
 554                 -- dot-o files.  Which is very confusing.
 555                 --
 556                 -- But the BCO parts can be unlinked just by
 557                 -- letting go of them (plus of course depopulating
 558                 -- the symbol table which is done in the main body)
 559            return False
 560 \end{code}
 561
 562
 563 %************************************************************************
 564 %*                                                                      *
 565                 Loading packages
 566 %*                                                                      *
 567 %************************************************************************
 568
 569
 570 \begin{code}
 571 data LibrarySpec
 572    = Object FilePath    -- Full path name of a .o file, including trailing .o
 573                         -- For dynamic objects only, try to find the object
 574                         -- file in all the directories specified in
 575                         -- v_Library_paths before giving up.
 576
 577    | DLL String         -- "Unadorned" name of a .DLL/.so
 578                         --  e.g.    On unix     "qt"  denotes "libqt.so"
 579                         --          On WinDoze  "burble"  denotes "burble.DLL"
 580                         --  loadDLL is platform-specific and adds the lib/.so/.DLL
 581                         --  suffixes platform-dependently
 582 #ifdef darwin_TARGET_OS
 583    | Framework String
 584 #endif
 585
 586 -- If this package is already part of the GHCi binary, we'll already
 587 -- have the right DLLs for this package loaded, so don't try to
 588 -- load them again.
 589 --
 590 -- But on Win32 we must load them 'again'; doing so is a harmless no-op
 591 -- as far as the loader is concerned, but it does initialise the list
 592 -- of DLL handles that rts/Linker.c maintains, and that in turn is
 593 -- used by lookupSymbol.  So we must call addDLL for each library
 594 -- just to get the DLL handle into the list.
 595 partOfGHCi
 596 #          ifndef mingw32_TARGET_OS
 597            = [ "base", "concurrent", "posix", "text", "util" ]
 598 #          else
 599            = [ ]
 600 #          endif
 601
 602 showLS (Object nm)  = "(static) " ++ nm
 603 showLS (DLL nm) = "(dynamic) " ++ nm
 604 #ifdef darwin_TARGET_OS
 605 showLS (Framework nm) = "(framework) " ++ nm
 606 #endif
 607
 608 linkPackages :: DynFlags -> [PackageName] -> IO ()
 609 -- Link exactly the specified packages, and their dependents
 610 -- (unless of course they are already linked)
 611 -- The dependents are linked automatically, and it doesn't matter
 612 -- what order you specify the input packages.
 613
 614 linkPackages dflags new_pkgs
 615    = do { pls     <- readIORef v_PersistentLinkerState
 616         ; pkg_map <- getPackageConfigMap
 617
 618         ; pkgs' <- link pkg_map (pkgs_loaded pls) new_pkgs
 619
 620         ; writeIORef v_PersistentLinkerState (pls { pkgs_loaded = pkgs' })
 621         }
 622    where
 623      link :: PackageConfigMap -> [PackageName] -> [PackageName] -> IO [PackageName]
 624      link pkg_map pkgs new_pkgs
 625         = foldM (link_one pkg_map) pkgs new_pkgs
 626
 627      link_one pkg_map pkgs new_pkg
 628         | new_pkg `elem` pkgs   -- Already linked
 629         = return pkgs
 630
 631         | Just pkg_cfg <- lookupPkg pkg_map new_pkg
 632         = do {  -- Link dependents first
 633                pkgs' <- link pkg_map pkgs (packageDependents pkg_cfg)
 634                 -- Now link the package itself
 635              ; linkPackage dflags pkg_cfg
 636              ; return (new_pkg : pkgs') }
 637
 638         | otherwise
 639         = throwDyn (CmdLineError ("unknown package name: " ++ packageNameString new_pkg))
 640
 641
 642 linkPackage :: DynFlags -> PackageConfig -> IO ()
 643 linkPackage dflags pkg
 644    = do
 645         let dirs      =  Packages.library_dirs pkg
 646         let libs      =  Packages.hs_libraries pkg ++ extra_libraries pkg
 647         classifieds   <- mapM (locateOneObj dirs) libs
 648 #ifdef darwin_TARGET_OS
 649         let fwDirs    =  Packages.framework_dirs pkg
 650         let frameworks=  Packages.extra_frameworks pkg
 651 #endif
 652
 653         -- Complication: all the .so's must be loaded before any of the .o's.
 654         let dlls = [ dll | DLL dll    <- classifieds ]
 655             objs = [ obj | Object obj <- classifieds ]
 656
 657         maybePutStr dflags ("Loading package " ++ Packages.name pkg ++ " ... ")
 658
 659         -- See comments with partOfGHCi
 660         when (Packages.name pkg `notElem` partOfGHCi) $ do
 661 #ifdef darwin_TARGET_OS
 662             loadFrameworks fwDirs frameworks
 663 #endif
 664             loadDynamics dirs dlls
 665
 666         -- After loading all the DLLs, we can load the static objects.
 667         mapM_ loadObj objs
 668
 669         maybePutStr dflags "linking ... "
 670         ok <- resolveObjs
 671         if succeeded ok then maybePutStrLn dflags "done."
 672               else panic ("can't load package `" ++ name pkg ++ "'")
 673
 674 loadDynamics dirs [] = return ()
 675 loadDynamics dirs (dll:dlls) = do
 676   r <- loadDynamic dirs dll
 677   case r of
 678     Nothing  -> loadDynamics dirs dlls
 679     Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: "
 680                                        ++ dll ++ " (" ++ err ++ ")" ))
 681 #ifdef darwin_TARGET_OS
 682 loadFrameworks dirs [] = return ()
 683 loadFrameworks dirs (fw:fws) = do
 684   r <- loadFramework dirs fw
 685   case r of
 686     Nothing  -> loadFrameworks dirs fws
 687     Just err -> throwDyn (CmdLineError ("can't load framework: "
 688                                        ++ fw ++ " (" ++ err ++ ")" ))
 689 #endif
 690
 691 -- Try to find an object file for a given library in the given paths.
 692 -- If it isn't present, we assume it's a dynamic library.
 693 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
 694 locateOneObj dirs lib
 695   = do  { mb_obj_path <- findFile mk_obj_path dirs
 696         ; case mb_obj_path of
 697             Just obj_path -> return (Object obj_path)
 698             Nothing       -> return (DLL lib) } -- we assume
 699    where
 700      mk_obj_path dir = dir ++ '/':lib ++ ".o"
 701
 702
 703 -- ----------------------------------------------------------------------------
 704 -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
 705
 706 -- return Nothing == success, else Just error message from dlopen
 707 loadDynamic paths rootname
 708   = do  { mb_dll <- findFile mk_dll_path paths
 709         ; case mb_dll of
 710             Just dll -> loadDLL dll
 711             Nothing  -> loadDLL (mkSOName rootname) }
 712                         -- Tried all our known library paths, so let
 713                         -- dlopen() search its own builtin paths now.
 714   where
 715     mk_dll_path dir = dir ++ '/':mkSOName rootname
 716
 717 #if defined(darwin_TARGET_OS)
 718 mkSOName root = "lib" ++ root ++ ".dylib"
 719 #elif defined(mingw32_TARGET_OS)
 720 -- Win32 DLLs have no .dll extension here, because addDLL tries
 721 -- both foo.dll and foo.drv
 722 mkSOName root = root
 723 #else
 724 mkSOName root = "lib" ++ root ++ ".so"
 725 #endif
 726
 727 -- Darwin / MacOS X only: load a framework
 728 -- a framework is a dynamic library packaged inside a directory of the same
 729 -- name. They are searched for in different paths than normal libraries.
 730 #ifdef darwin_TARGET_OS
 731 loadFramework extraPaths rootname
 732    = do { mb_fwk <- findFile mk_fwk (extraPaths ++ defaultFrameworkPaths)
 733         ; case mb_fwk of
 734             Just fwk_path -> loadDLL fwk_path
 735             Nothing       -> return (Just "not found")
 736                 -- Tried all our known library paths, but dlopen()
 737                 -- has no built-in paths for frameworks: give up
 738    where
 739      mk_fwk dir = dir ++ '/' : rootname ++ ".framework/" ++ rootname
 740 #endif
 741 \end{code}
 742
 743 %************************************************************************
 744 %*                                                                      *
 745                 Helper functions
 746 %*                                                                      *
 747 %************************************************************************
 748
 749 \begin{code}
 750 findFile :: (FilePath -> FilePath)      -- Maps a directory path to a file path
 751          -> [FilePath]                  -- Directories to look in
 752          -> IO (Maybe FilePath)         -- The first file path to match
 753 findFile mk_file_path []
 754   = return Nothing
 755 findFile mk_file_path (dir:dirs)
 756   = do  { let file_path = mk_file_path dir
 757         ; b <- doesFileExist file_path
 758         ; if b then
 759              return (Just file_path)
 760           else
 761              findFile mk_file_path dirs }
 762 \end{code}
 763
 764 \begin{code}
 765 maybePutStr dflags s | verbosity dflags > 0 = putStr s
 766                      | otherwise            = return ()
 767
 768 maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
 769                        | otherwise            = return ()
 770 \end{code}