X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FLinker.lhs;h=ab4cafe246a5ec25086fccb0008a11c736ff6a4e;hb=153b9cb9b11e05c4edb1b6bc0a7b972660e41f70;hp=0849859bae8ad5aa5405a64856f20fe608ae3a06;hpb=423d477bfecd490de1449c59325c8776f91d7aac;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/Linker.lhs b/ghc/compiler/ghci/Linker.lhs index 0849859..ab4cafe 100644 --- a/ghc/compiler/ghci/Linker.lhs +++ b/ghc/compiler/ghci/Linker.lhs @@ -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,20 +28,20 @@ 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 DriverState ( v_Library_paths, v_Opt_l, v_Ld_inputs, getStaticOpts ) 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, findLinkable, 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 CmdLineOpts ( DynFlags(..) ) import BasicTypes ( SuccessFlag(..), succeeded, failed ) import Outputable import Panic ( GhcException(..) ) @@ -106,22 +105,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 +140,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,28 +185,25 @@ 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 @@ -315,11 +313,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 dflags hpt (eps_PIT eps) needed_mods -- Link the packages and modules required ; linkPackages dflags pkgs @@ -354,12 +353,12 @@ linkExpr hsc_env root_ul_bco dieWith msg = throwDyn (ProgramError (showSDoc msg)) -getLinkDeps :: HomePackageTable -> PackageIfaceTable +getLinkDeps :: DynFlags -> 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 dflags hpt pit mods -- Find all the packages and linkables that a set of modules depends on = do { pls <- readIORef v_PersistentLinkerState ; let { @@ -371,7 +370,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 +380,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 +402,24 @@ 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 + | Just mod_info <- lookupModuleEnv hpt mod_name = return (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 dflags 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 ; case mb_lnk of { Nothing -> no_obj mod_name ; Just lnk -> return lnk - }}}} + }} \end{code} @@ -461,7 +462,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 +471,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 +643,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 +714,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 +729,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 +744,33 @@ 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 ++ Packages.extraLibraries pkg + ++ [ lib | '-':'l':lib <- Packages.extraLdOpts 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 +791,7 @@ linkPackage dflags pkg maybePutStr dflags "linking ... " ok <- resolveObjs if succeeded ok then maybePutStrLn dflags "done." - else throwDyn (InstallationError ("unable to 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 +803,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.extraFrameworks pkg load fw = do r <- loadFramework fw_dirs fw case r of @@ -819,9 +820,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") -- ----------------------------------------------------------------------------