X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FLinker.lhs;h=3a5ecf8a6d62f508d37cd0449d162112dcaedfcc;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=ffd16e2792e663174779a65f5ebbb8de9e77b1ae;hpb=5220fda752f65ac62bd9f5269c11a7f345293f69;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/Linker.lhs b/ghc/compiler/ghci/Linker.lhs index ffd16e2..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,11 +16,11 @@ 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 "../includes/config.h" #include "HsVersions.h" import ObjLink ( loadDLL, loadObj, unloadObj, resolveObjs, initObjLinker ) @@ -29,35 +29,33 @@ import ByteCodeItbls ( ItblEnv ) import ByteCodeAsm ( CompiledByteCode(..), bcoFreeNames, UnlinkedBCO(..)) import Packages -import DriverState ( v_Library_paths, v_Opt_l, v_Ld_inputs, getStaticOpts, v_ExplicitPackages ) import DriverPhases ( isObjectFilename, isDynLibFilename ) -import DriverUtil ( getFileSuffix ) -#ifdef darwin_TARGET_OS -import DriverState ( v_Cmdline_frameworks, v_Framework_paths ) -#endif -import Finder ( findModule, findLinkable ) +import Finder ( findModule, findObjectLinkableMaybe, FindResult(..) ) import HscTypes -import Name ( Name, nameModule, nameModuleName, isExternalName, isWiredInName ) +import Name ( Name, nameModule, isExternalName, isWiredInName ) import NameEnv import NameSet ( nameSetToList ) import Module import ListSetOps ( minusList ) -import CmdLineOpts ( DynFlags(verbosity), getDynFlags ) +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(..) ) @@ -106,25 +104,31 @@ data PersistentLinkerState -- The currently-loaded packages; always object code -- Held, as usual, in dependency order; though I am not sure if -- that is really important - pkgs_loaded :: [PackageName] + pkgs_loaded :: [PackageId] } -emptyPLS :: PersistentLinkerState -emptyPLS = PersistentLinkerState { closure_env = emptyNameEnv, - itbl_env = emptyNameEnv, - pkgs_loaded = init_pkgs_loaded, - bcos_loaded = [], - objs_loaded = [] } - --- Packages that don't need loading, because the compiler --- shares them with the interpreted program. --- --- The linker's symbol table is populated with RTS symbols using an --- explicit list. See rts/Linker.c for details. -init_pkgs_loaded = [ FSLIT("rts") ] +emptyPLS :: DynFlags -> PersistentLinkerState +emptyPLS dflags = PersistentLinkerState { + closure_env = emptyNameEnv, + itbl_env = emptyNameEnv, + pkgs_loaded = init_pkgs, + bcos_loaded = [], + objs_loaded = [] } + -- Packages that don't need loading, because the compiler + -- shares them with the interpreted program. + -- + -- The linker's symbol table is populated with RTS symbols using an + -- explicit list. See rts/Linker.c for details. + where init_pkgs + | ExtPackage rts_id <- rtsPackageId (pkgState dflags) = [rts_id] + | otherwise = [] \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 @@ -133,18 +137,30 @@ 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 -- (these are the temporary bindings from the command line). -- Used to filter both the ClosureEnv and ItblEnv -filterNameMap :: [ModuleName] -> NameEnv (Name, a) -> NameEnv (Name, a) +filterNameMap :: [Module] -> NameEnv (Name, a) -> NameEnv (Name, a) filterNameMap mods env = filterNameEnv keep_elt env where keep_elt (n,_) = isExternalName n - && (nameModuleName n `elem` mods) + && (nameModule n `elem` mods) \end{code} @@ -184,43 +200,40 @@ d) Loading any .o/.dll files specified on the command line, e) Loading any MacOS frameworks \begin{code} -initDynLinker :: IO () +initDynLinker :: DynFlags -> IO () -- This function is idempotent; if called more than once, it does nothing -- This is useful in Template Haskell, where we call it before trying to link -initDynLinker +initDynLinker dflags = do { done <- readIORef v_InitLinkerDone ; if done then return () else do { writeIORef v_InitLinkerDone True - ; reallyInitDynLinker } + ; reallyInitDynLinker dflags } } -reallyInitDynLinker - = do { dflags <- getDynFlags - - -- Initialise the linker state - ; writeIORef v_PersistentLinkerState emptyPLS +reallyInitDynLinker dflags + = do { -- Initialise the linker state + ; writeIORef v_PersistentLinkerState (emptyPLS dflags) -- (a) initialise the C dynamic linker ; initObjLinker -- (b) Load packages from the command-line - ; expl <- readIORef v_ExplicitPackages - ; linkPackages dflags expl + ; 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 = [] @@ -315,11 +328,12 @@ linkExpr :: HscEnv -> UnlinkedBCO -> IO HValue linkExpr hsc_env root_ul_bco = do { -- Initialise the linker (if it's not been done already) - initDynLinker + let dflags = hsc_dflags hsc_env + ; initDynLinker dflags -- Find what packages and linkables are required ; eps <- readIORef (hsc_EPS hsc_env) - ; (lnks, pkgs) <- getLinkDeps 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 @@ -354,12 +368,12 @@ linkExpr hsc_env root_ul_bco dieWith msg = throwDyn (ProgramError (showSDoc msg)) -getLinkDeps :: HomePackageTable -> PackageIfaceTable +getLinkDeps :: HscEnv -> HomePackageTable -> PackageIfaceTable -> [Module] -- If you need these - -> IO ([Linkable], [PackageName]) -- ... then link these first + -> IO ([Linkable], [PackageId]) -- ... then link these first -- Fails with an IO exception if it can't find enough files -getLinkDeps 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 { @@ -371,7 +385,7 @@ getLinkDeps hpt pit mods mods_needed = nub (concat mods_s) `minusList` linked_mods ; pkgs_needed = nub (concat pkgs_s) `minusList` pkgs_loaded pls ; - linked_mods = map linkableModName (objs_loaded pls ++ bcos_loaded pls) + linked_mods = map linkableModule (objs_loaded pls ++ bcos_loaded pls) } ; -- 3. For each dependent module, find its linkable @@ -381,14 +395,14 @@ getLinkDeps hpt pit mods return (lnks_needed, pkgs_needed) } where - get_deps :: Module -> ([ModuleName],[PackageName]) + get_deps :: Module -> ([Module],[PackageId]) -- Get the things needed for the specified module -- This is rather similar to the code in RnNames.importsFromImportDecl get_deps mod - | isHomeModule (mi_module iface) - = (moduleName mod : [m | (m,_) <- dep_mods deps], dep_pkgs deps) + | ExtPackage p <- mi_package iface + = ([], p : dep_pkgs deps) | otherwise - = ([], mi_package iface : dep_pkgs deps) + = (mod : [m | (m,_) <- dep_mods deps], dep_pkgs deps) where iface = get_iface mod deps = mi_deps iface @@ -403,22 +417,25 @@ getLinkDeps hpt pit mods -- This one is a build-system bug get_linkable mod_name -- A home-package module - | Just mod_info <- lookupModuleEnvByName hpt mod_name - = return (hm_linkable mod_info) + | Just mod_info <- lookupModuleEnv hpt mod_name + = 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 mod_name ; + do { mb_stuff <- findModule hsc_env mod_name False ; case mb_stuff of { - Left _ -> no_obj mod_name ; - Right (_, loc) -> do { + Found loc _ -> found loc mod_name ; + _ -> no_obj mod_name + }} + 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 - }}}} + }} \end{code} @@ -461,7 +478,7 @@ partitionLinkable li other -> [li] -findModuleLinkable_maybe :: [Linkable] -> ModuleName -> Maybe Linkable +findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable findModuleLinkable_maybe lis mod = case [LM time nm us | LM time nm us <- lis, nm == mod] of [] -> Nothing @@ -470,7 +487,7 @@ findModuleLinkable_maybe lis mod linkableInSet :: Linkable -> [Linkable] -> Bool linkableInSet l objs_loaded = - case findModuleLinkable_maybe objs_loaded (linkableModName l) of + case findModuleLinkable_maybe objs_loaded (linkableModule l) of Nothing -> False Just m -> linkableTime l == linkableTime m \end{code} @@ -615,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 @@ -642,7 +657,7 @@ unload_wkr dflags linkables pls objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls) bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls) - let bcos_retained = map linkableModName bcos_loaded' + let bcos_retained = map linkableModule bcos_loaded' itbl_env' = filterNameMap bcos_retained (itbl_env pls) closure_env' = filterNameMap bcos_retained (closure_env pls) new_pls = pls { itbl_env = itbl_env', @@ -713,7 +728,7 @@ showLS (DLL nm) = "(dynamic) " ++ nm showLS (DLLPath nm) = "(dynamic) " ++ nm showLS (Framework nm) = "(framework) " ++ nm -linkPackages :: DynFlags -> [PackageName] -> IO () +linkPackages :: DynFlags -> [PackageId] -> IO () -- Link exactly the specified packages, and their dependents -- (unless of course they are already linked) -- The dependents are linked automatically, and it doesn't matter @@ -728,14 +743,14 @@ linkPackages :: DynFlags -> [PackageName] -> IO () linkPackages dflags new_pkgs = do { pls <- readIORef v_PersistentLinkerState - ; pkg_map <- getPackageConfigMap + ; let pkg_map = pkgIdMap (pkgState dflags) ; pkgs' <- link pkg_map (pkgs_loaded pls) new_pkgs ; writeIORef v_PersistentLinkerState (pls { pkgs_loaded = pkgs' }) } where - link :: PackageConfigMap -> [PackageName] -> [PackageName] -> IO [PackageName] + link :: PackageConfigMap -> [PackageId] -> [PackageId] -> IO [PackageId] link pkg_map pkgs new_pkgs = foldM (link_one pkg_map) pkgs new_pkgs @@ -743,33 +758,44 @@ linkPackages dflags new_pkgs | new_pkg `elem` pkgs -- Already linked = return pkgs - | Just pkg_cfg <- lookupPkg pkg_map new_pkg + | Just pkg_cfg <- lookupPackage pkg_map new_pkg = do { -- Link dependents first - pkgs' <- link pkg_map pkgs (packageDependents pkg_cfg) + pkgs' <- link pkg_map pkgs (map mkPackageId (depends pkg_cfg)) -- Now link the package itself ; linkPackage dflags pkg_cfg ; return (new_pkg : pkgs') } | otherwise - = throwDyn (CmdLineError ("unknown package name: " ++ packageNameString new_pkg)) + = throwDyn (CmdLineError ("unknown package: " ++ packageIdString new_pkg)) linkPackage :: DynFlags -> PackageConfig -> IO () linkPackage dflags pkg = do - let dirs = Packages.library_dirs pkg - let libs = Packages.hs_libraries pkg ++ extra_libraries pkg - ++ [ lib | '-':'l':lib <- extra_ld_opts pkg ] + let dirs = Packages.libraryDirs 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. let dlls = [ dll | DLL dll <- classifieds ] objs = [ obj | Object obj <- classifieds ] - maybePutStr dflags ("Loading package " ++ Packages.name pkg ++ " ... ") + maybePutStr dflags ("Loading package " ++ showPackageId (package pkg) ++ " ... ") -- See comments with partOfGHCi - when (Packages.name pkg `notElem` partOfGHCi) $ do + when (pkgName (package pkg) `notElem` partOfGHCi) $ do loadFrameworks pkg -- When a library A needs symbols from a library B, the order in -- extra_libraries/extra_ld_opts is "-lA -lB", because that's the @@ -790,7 +816,7 @@ linkPackage dflags pkg maybePutStr dflags "linking ... " ok <- resolveObjs if succeeded ok then maybePutStrLn dflags "done." - else panic ("can't load package `" ++ name pkg ++ "'") + else throwDyn (InstallationError ("unable to load package `" ++ showPackageId (package pkg) ++ "'")) load_dyn dirs dll = do r <- loadDynamic dirs dll case r of @@ -802,8 +828,8 @@ loadFrameworks pkg = return () #else loadFrameworks pkg = mapM_ load frameworks where - fw_dirs = Packages.framework_dirs pkg - frameworks = Packages.extra_frameworks pkg + fw_dirs = Packages.frameworkDirs pkg + frameworks = Packages.frameworks pkg load fw = do r <- loadFramework fw_dirs fw case r of @@ -819,9 +845,14 @@ locateOneObj dirs lib = do { mb_obj_path <- findFile mk_obj_path dirs ; case mb_obj_path of Just obj_path -> return (Object obj_path) - Nothing -> return (DLL lib) } -- We assume + Nothing -> + do { mb_lib_path <- findFile mk_dyn_lib_path dirs + ; case mb_lib_path of + Just lib_path -> return (DLL (lib ++ "_dyn")) + Nothing -> return (DLL lib) }} -- We assume where - mk_obj_path dir = dir ++ '/':lib ++ ".o" + mk_obj_path dir = dir `joinFileName` (lib `joinFileExt` "o") + mk_dyn_lib_path dir = dir `joinFileName` mkSOName (lib ++ "_dyn") -- ---------------------------------------------------------------------------- @@ -836,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 @@ -860,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