X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FLinker.lhs;h=1ac21e3363f274c6a566bc96e2e0241c9cf41844;hb=66994acb3d88236e6a4def84f7162c95ed5945d2;hp=5f19e2b62aa1a5346538c188e74d48c3957c8ebe;hpb=ceaf8381097ee7587ea60006ed2ee3015a6ee50c;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/Linker.lhs b/ghc/compiler/ghci/Linker.lhs index 5f19e2b..1ac21e3 100644 --- a/ghc/compiler/ghci/Linker.lhs +++ b/ghc/compiler/ghci/Linker.lhs @@ -15,12 +15,12 @@ necessary. {-# OPTIONS -optc-DNON_POSIX_SOURCE -#include "Linker.h" #-} -module Linker ( HValue, initDynLinker, showLinkerState, +module Linker ( HValue, showLinkerState, linkExpr, unload, extendLinkEnv, linkPackages, ) where -#include "../includes/config.h" +#include "../includes/ghcconfig.h" #include "HsVersions.h" import ObjLink ( loadDLL, loadObj, unloadObj, resolveObjs, initObjLinker ) @@ -30,16 +30,17 @@ 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 HscTypes -import Name ( Name, nameModule, isExternalName ) +import Name ( Name, nameModule, nameModuleName, isExternalName, isWiredInName ) import NameEnv import NameSet ( nameSetToList ) import Module -import FastString ( FastString(..), unpackFS ) import ListSetOps ( minusList ) import CmdLineOpts ( DynFlags(verbosity), getDynFlags ) import BasicTypes ( SuccessFlag(..), succeeded, failed ) @@ -143,7 +144,7 @@ filterNameMap mods env = filterNameEnv keep_elt env where keep_elt (n,_) = isExternalName n - && (moduleName (nameModule n) `elem` mods) + && (nameModuleName n `elem` mods) \end{code} @@ -211,8 +212,10 @@ reallyInitDynLinker ; let minus_ls = [ lib | '-':'l':lib <- opt_l ] -- (d) Link .o files from the command-line - ; lib_paths <- readIORef v_Library_paths - ; cmdline_objs <- readIORef v_Ld_inputs + ; lib_paths <- readIORef v_Library_paths + ; cmdline_ld_inputs <- readIORef v_Ld_inputs + + ; classified_ld_inputs <- mapM classifyLdInput cmdline_ld_inputs -- (e) Link any MacOS frameworks #ifdef darwin_TARGET_OS @@ -223,7 +226,7 @@ reallyInitDynLinker ; let framework_paths = [] #endif -- Finally do (c),(d),(e) - ; let cmdline_lib_specs = map Object cmdline_objs + ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ] ++ map DLL minus_ls ++ map Framework frameworks ; if null cmdline_lib_specs then return () @@ -237,6 +240,14 @@ reallyInitDynLinker else throwDyn (InstallationError "linking extra libraries/objects failed") }} +classifyLdInput :: FilePath -> IO (Maybe LibrarySpec) +classifyLdInput f + | isObjectFilename f = return (Just (Object f)) + | isDynLibFilename f = return (Just (DLLPath f)) + | otherwise = do + hPutStrLn stderr ("Warning: ignoring unrecognised input `" ++ f ++ "'") + return Nothing + preloadLib :: DynFlags -> [String] -> [String] -> LibrarySpec -> IO () preloadLib dflags lib_paths framework_paths lib_spec = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ") @@ -251,7 +262,13 @@ preloadLib dflags lib_paths framework_paths lib_spec case maybe_errstr of Nothing -> maybePutStrLn dflags "done" Just mm -> preloadFailed mm lib_paths lib_spec - + + DLLPath dll_path + -> do maybe_errstr <- loadDLL dll_path + case maybe_errstr of + Nothing -> maybePutStrLn dflags "done" + Just mm -> preloadFailed mm lib_paths lib_spec + #ifdef darwin_TARGET_OS Framework framework -> do maybe_errstr <- loadFramework framework_paths framework @@ -287,8 +304,7 @@ preloadLib dflags lib_paths framework_paths lib_spec %************************************************************************ \begin{code} -linkExpr :: HscEnv -> PersistentCompilerState - -> UnlinkedBCO -> IO HValue +linkExpr :: HscEnv -> UnlinkedBCO -> IO HValue -- Link a single expression, *including* first linking packages and -- modules that this expression depends on. @@ -296,13 +312,14 @@ linkExpr :: HscEnv -> PersistentCompilerState -- Raises an IO exception if it can't find a compiled version of the -- dependents to link. -linkExpr hsc_env pcs root_ul_bco +linkExpr hsc_env root_ul_bco = do { -- Initialise the linker (if it's not been done already) initDynLinker -- Find what packages and linkables are required - ; (lnks, pkgs) <- getLinkDeps hpt pit needed_mods + ; eps <- readIORef (hsc_EPS hsc_env) + ; (lnks, pkgs) <- getLinkDeps hpt (eps_PIT eps) needed_mods -- Link the packages and modules required ; linkPackages dflags pkgs @@ -321,13 +338,19 @@ linkExpr hsc_env pcs root_ul_bco ; return root_hval }} where - pit = eps_PIT (pcs_EPS pcs) hpt = hsc_HPT hsc_env dflags = hsc_dflags hsc_env free_names = nameSetToList (bcoFreeNames root_ul_bco) needed_mods :: [Module] - needed_mods = [ nameModule n | n <- free_names, isExternalName n ] + needed_mods = [ nameModule n | n <- free_names, + isExternalName n, -- Names from other modules + not (isWiredInName n) -- Exclude wired-in names + ] -- (see note below) + -- Exclude wired-in names because we may not have read + -- their interface files, so getLinkDeps will fail + -- All wired-in names are in the base package, which we link + -- by default, so we can safely ignore them here. dieWith msg = throwDyn (ProgramError (showSDoc msg)) @@ -445,9 +468,6 @@ findModuleLinkable_maybe lis mod [li] -> Just li many -> pprPanic "findModuleLinkable" (ppr mod) -filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] -> [Linkable] -filterModuleLinkables p ls = filter (p . linkableModName) ls - linkableInSet :: Linkable -> [Linkable] -> Bool linkableInSet l objs_loaded = case findModuleLinkable_maybe objs_loaded (linkableModName l) of @@ -622,8 +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 objs_retained = map linkableModName objs_loaded' - bcos_retained = map linkableModName bcos_loaded' + let bcos_retained = map linkableModName 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', @@ -668,6 +687,9 @@ data LibrarySpec -- loadDLL is platform-specific and adds the lib/.so/.DLL -- suffixes platform-dependently + | DLLPath FilePath -- Absolute or relative pathname to a dynamic library + -- (ends with .dll or .so). + | Framework String -- Only used for darwin, but does no harm -- If this package is already part of the GHCi binary, we'll already @@ -683,11 +705,12 @@ partOfGHCi # if defined(mingw32_TARGET_OS) || defined(darwin_TARGET_OS) = [ ] # else - = [ "base", "haskell98", "haskell-src", "readline" ] + = [ "base", "haskell98", "template-haskell", "readline" ] # endif showLS (Object nm) = "(static) " ++ nm showLS (DLL nm) = "(dynamic) " ++ nm +showLS (DLLPath nm) = "(dynamic) " ++ nm showLS (Framework nm) = "(framework) " ++ nm linkPackages :: DynFlags -> [PackageName] -> IO () @@ -734,29 +757,40 @@ linkPackages dflags new_pkgs 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 - mapM_ (load_dyn dirs) dlls + -- 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 + -- way ld expects it for static linking. Dynamic linking is a + -- different story: When A has no dependency information for B, + -- dlopen-ing A with RTLD_NOW (see addDLL in Linker.c) will fail + -- when B has not been loaded before. In a nutshell: Reverse the + -- order of DLLs for dynamic linking. + -- This fixes a problem with the HOpenGL package (see "Compiling + -- HOpenGL under recent versions of GHC" on the HOpenGL list). + mapM_ (load_dyn dirs) (reverse dlls) -- After loading all the DLLs, we can load the static objects. + -- Ordering isn't important here, because we do one final link + -- step to resolve everything. mapM_ loadObj objs 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 @@ -768,8 +802,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