X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FLinker.lhs;h=3a5ecf8a6d62f508d37cd0449d162112dcaedfcc;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=d87c2bbd25961d9791f09045021960ffce4d64e6;hpb=d1c1b7d0e7b94ede238845c91f58582bad3b3ef3;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/Linker.lhs b/ghc/compiler/ghci/Linker.lhs index d87c2bb..3a5ecf8 100644 --- a/ghc/compiler/ghci/Linker.lhs +++ b/ghc/compiler/ghci/Linker.lhs @@ -1,5 +1,5 @@ % -% (c) The University of Glasgow 2000 +% (c) The University of Glasgow 2005 % -- -------------------------------------- @@ -16,8 +16,9 @@ necessary. {-# OPTIONS -optc-DNON_POSIX_SOURCE -#include "Linker.h" #-} module Linker ( HValue, showLinkerState, - linkExpr, unload, extendLinkEnv, - linkPackages, + linkExpr, unload, extendLinkEnv, withExtendedLinkEnv, + extendLoadedPkgs, + linkPackages,initDynLinker ) where #include "HsVersions.h" @@ -29,30 +30,32 @@ import ByteCodeAsm ( CompiledByteCode(..), bcoFreeNames, UnlinkedBCO(..)) import Packages import DriverPhases ( isObjectFilename, isDynLibFilename ) -import Util ( getFileSuffix ) -import Finder ( findModule, findLinkable, FindResult(..) ) +import Finder ( findModule, findObjectLinkableMaybe, FindResult(..) ) import HscTypes import Name ( Name, nameModule, isExternalName, isWiredInName ) import NameEnv import NameSet ( nameSetToList ) import Module import ListSetOps ( minusList ) -import DynFlags ( DynFlags(..) ) +import DynFlags ( DynFlags(..), getOpts ) import BasicTypes ( SuccessFlag(..), succeeded, failed ) import Outputable import Panic ( GhcException(..) ) -import Util ( zipLazy, global ) +import Util ( zipLazy, global, joinFileExt, joinFileName, suffixOf ) +import StaticFlags ( v_Ld_inputs ) +import ErrUtils ( debugTraceMsg ) -- Standard libraries import Control.Monad ( when, filterM, foldM ) -import Data.IORef ( IORef, readIORef, writeIORef ) +import Data.IORef ( IORef, readIORef, writeIORef, modifyIORef ) import Data.List ( partition, nub ) import System.IO ( putStr, putStrLn, hPutStrLn, stderr, fixIO ) import System.Directory ( doesFileExist ) -import Control.Exception ( block, throwDyn ) +import Control.Exception ( block, throwDyn, bracket ) +import Maybe ( isJust, fromJust ) #if __GLASGOW_HASKELL__ >= 503 import GHC.IOBase ( IO(..) ) @@ -122,6 +125,10 @@ emptyPLS dflags = PersistentLinkerState { \end{code} \begin{code} +extendLoadedPkgs :: [PackageId] -> IO () +extendLoadedPkgs pkgs + = modifyIORef v_PersistentLinkerState (\s -> s{pkgs_loaded = pkgs ++ pkgs_loaded s}) + extendLinkEnv :: [(Name,HValue)] -> IO () -- Automatically discards shadowed bindings extendLinkEnv new_bindings @@ -130,6 +137,18 @@ extendLinkEnv new_bindings new_pls = pls { closure_env = new_closure_env } writeIORef v_PersistentLinkerState new_pls +withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a +withExtendedLinkEnv new_env action + = bracket set_new_env + reset_old_env + (const action) + where set_new_env = do pls <- readIORef v_PersistentLinkerState + let new_closure_env = extendClosureEnv (closure_env pls) new_env + new_pls = pls { closure_env = new_closure_env } + writeIORef v_PersistentLinkerState new_pls + return pls + reset_old_env pls = writeIORef v_PersistentLinkerState pls + -- filterNameMap removes from the environment all entries except -- those for a given set of modules; -- Note that this removes all *local* (i.e. non-isExternal) names too @@ -202,19 +221,19 @@ reallyInitDynLinker dflags ; linkPackages dflags (explicitPackages (pkgState dflags)) -- (c) Link libraries from the command-line - ; opt_l <- getStaticOpts v_Opt_l - ; let minus_ls = [ lib | '-':'l':lib <- opt_l ] + ; let optl = getOpts dflags opt_l + ; let minus_ls = [ lib | '-':'l':lib <- optl ] -- (d) Link .o files from the command-line - ; lib_paths <- readIORef v_Library_paths + ; let lib_paths = libraryPaths dflags ; cmdline_ld_inputs <- readIORef v_Ld_inputs ; classified_ld_inputs <- mapM classifyLdInput cmdline_ld_inputs -- (e) Link any MacOS frameworks #ifdef darwin_TARGET_OS - ; framework_paths <- readIORef v_Framework_paths - ; frameworks <- readIORef v_Cmdline_frameworks + ; let framework_paths = frameworkPaths dflags + ; let frameworks = cmdlineFrameworks dflags #else ; let frameworks = [] ; let framework_paths = [] @@ -314,7 +333,7 @@ linkExpr hsc_env root_ul_bco -- Find what packages and linkables are required ; eps <- readIORef (hsc_EPS hsc_env) - ; (lnks, pkgs) <- getLinkDeps dflags hpt (eps_PIT eps) needed_mods + ; (lnks, pkgs) <- getLinkDeps hsc_env hpt (eps_PIT eps) needed_mods -- Link the packages and modules required ; linkPackages dflags pkgs @@ -349,12 +368,12 @@ linkExpr hsc_env root_ul_bco dieWith msg = throwDyn (ProgramError (showSDoc msg)) -getLinkDeps :: DynFlags -> HomePackageTable -> PackageIfaceTable +getLinkDeps :: HscEnv -> HomePackageTable -> PackageIfaceTable -> [Module] -- If you need these -> IO ([Linkable], [PackageId]) -- ... then link these first -- Fails with an IO exception if it can't find enough files -getLinkDeps dflags hpt pit mods +getLinkDeps hsc_env hpt pit mods -- Find all the packages and linkables that a set of modules depends on = do { pls <- readIORef v_PersistentLinkerState ; let { @@ -399,11 +418,12 @@ getLinkDeps dflags hpt pit mods get_linkable mod_name -- A home-package module | Just mod_info <- lookupModuleEnv hpt mod_name - = return (hm_linkable mod_info) + = ASSERT(isJust (hm_linkable mod_info)) + return (fromJust (hm_linkable mod_info)) | otherwise = -- It's not in the HPT because we are in one shot mode, -- so use the Finder to get a ModLocation... - do { mb_stuff <- findModule dflags mod_name False ; + do { mb_stuff <- findModule hsc_env mod_name False ; case mb_stuff of { Found loc _ -> found loc mod_name ; _ -> no_obj mod_name @@ -411,7 +431,7 @@ getLinkDeps dflags hpt pit mods found loc mod_name = do { -- ...and then find the linkable for it - mb_lnk <- findLinkable mod_name loc ; + mb_lnk <- findObjectLinkableMaybe mod_name loc ; case mb_lnk of { Nothing -> no_obj mod_name ; Just lnk -> return lnk @@ -612,19 +632,17 @@ unload :: DynFlags -> [Linkable] -> IO () unload dflags linkables = block $ do -- block, so we're safe from Ctrl-C in here + + -- Initialise the linker (if it's not been done already) + initDynLinker dflags pls <- readIORef v_PersistentLinkerState new_pls <- unload_wkr dflags linkables pls writeIORef v_PersistentLinkerState new_pls - let verb = verbosity dflags - when (verb >= 3) $ do - hPutStrLn stderr (showSDoc - (text "unload: retaining objs" <+> ppr (objs_loaded new_pls))) - hPutStrLn stderr (showSDoc - (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls))) - - return () + debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls)) + debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls)) + return () unload_wkr :: DynFlags -> [Linkable] -- stable linkables @@ -755,8 +773,19 @@ linkPackage :: DynFlags -> PackageConfig -> IO () linkPackage dflags pkg = do let dirs = Packages.libraryDirs pkg - let libs = Packages.hsLibraries pkg ++ Packages.extraLibraries pkg - ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ] + + let libs = Packages.hsLibraries pkg + -- Because of slight differences between the GHC dynamic linker and + -- the native system linker some packages have to link with a + -- different list of libraries when using GHCi. Examples include: libs + -- that are actually gnu ld scripts, and the possability that the .a + -- libs do not exactly match the .so/.dll equivalents. So if the + -- package file provides an "extra-ghci-libraries" field then we use + -- that instead of the "extra-libraries" field. + ++ (if null (Packages.extraGHCiLibraries pkg) + then Packages.extraLibraries pkg + else Packages.extraGHCiLibraries pkg) + ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ] classifieds <- mapM (locateOneObj dirs) libs -- Complication: all the .so's must be loaded before any of the .o's. @@ -822,8 +851,8 @@ locateOneObj dirs lib Just lib_path -> return (DLL (lib ++ "_dyn")) Nothing -> return (DLL lib) }} -- We assume where - mk_obj_path dir = dir ++ '/':lib ++ ".o" - mk_dyn_lib_path dir = dir ++ '/':mkSOName (lib ++ "_dyn") + mk_obj_path dir = dir `joinFileName` (lib `joinFileExt` "o") + mk_dyn_lib_path dir = dir `joinFileName` mkSOName (lib ++ "_dyn") -- ---------------------------------------------------------------------------- @@ -838,16 +867,16 @@ loadDynamic paths rootname -- Tried all our known library paths, so let -- dlopen() search its own builtin paths now. where - mk_dll_path dir = dir ++ '/':mkSOName rootname + mk_dll_path dir = dir `joinFileName` mkSOName rootname #if defined(darwin_TARGET_OS) -mkSOName root = "lib" ++ root ++ ".dylib" +mkSOName root = ("lib" ++ root) `joinFileExt` "dylib" #elif defined(mingw32_TARGET_OS) -- Win32 DLLs have no .dll extension here, because addDLL tries -- both foo.dll and foo.drv mkSOName root = root #else -mkSOName root = "lib" ++ root ++ ".so" +mkSOName root = ("lib" ++ root) `joinFileExt` "so" #endif -- Darwin / MacOS X only: load a framework @@ -862,7 +891,7 @@ loadFramework extraPaths rootname -- Tried all our known library paths, but dlopen() -- has no built-in paths for frameworks: give up where - mk_fwk dir = dir ++ '/' : rootname ++ ".framework/" ++ rootname + mk_fwk dir = dir `joinFileName` (rootname ++ ".framework/" ++ rootname) -- sorry for the hardcoded paths, I hope they won't change anytime soon: defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"] #endif