X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FLinker.lhs;h=4ebbc8b9561d5db0edd74a60cd190c43cbd5856a;hb=70960d2ef24add2911e5613ca25cf1d226b2e082;hp=1ac21e3363f274c6a566bc96e2e0241c9cf41844;hpb=66994acb3d88236e6a4def84f7162c95ed5945d2;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/Linker.lhs b/ghc/compiler/ghci/Linker.lhs index 1ac21e3..4ebbc8b 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 % -- -------------------------------------- @@ -20,7 +20,6 @@ module Linker ( HValue, showLinkerState, linkPackages, ) where -#include "../includes/ghcconfig.h" #include "HsVersions.h" import ObjLink ( loadDLL, loadObj, unloadObj, resolveObjs, initObjLinker ) @@ -29,24 +28,21 @@ 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 Util ( getFileSuffix ) +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 StaticFlags ( v_Ld_inputs ) -- Standard libraries import Control.Monad ( when, filterM, foldM ) @@ -58,6 +54,7 @@ import System.IO ( putStr, putStrLn, hPutStrLn, stderr, fixIO ) import System.Directory ( doesFileExist ) import Control.Exception ( block, throwDyn ) +import Maybe ( isJust, fromJust ) #if __GLASGOW_HASKELL__ >= 503 import GHC.IOBase ( IO(..) ) @@ -106,22 +103,24 @@ 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} @@ -139,12 +138,12 @@ extendLinkEnv new_bindings -- (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 +183,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 +311,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 +351,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 +368,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 +378,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 +400,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 +461,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 +470,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} @@ -642,7 +642,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 +713,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 +728,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,15 +743,15 @@ 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 () @@ -759,7 +759,7 @@ linkPackage dflags pkg = do let dirs = Packages.libraryDirs pkg let libs = Packages.hsLibraries pkg ++ Packages.extraLibraries pkg - ++ [ lib | '-':'l':lib <- Packages.extraLdOpts 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. @@ -803,7 +803,7 @@ loadFrameworks pkg = return () loadFrameworks pkg = mapM_ load frameworks where fw_dirs = Packages.frameworkDirs pkg - frameworks = Packages.extraFrameworks pkg + frameworks = Packages.frameworks pkg load fw = do r <- loadFramework fw_dirs fw case r of @@ -819,9 +819,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_dyn_lib_path dir = dir ++ '/':mkSOName (lib ++ "_dyn") -- ----------------------------------------------------------------------------