X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FLinker.lhs;h=bb968ffa34c7006dc06fb31b184b5d18c3e38879;hb=b374a3eea08e9dcb5d937232ce06bcf1eb3a73df;hp=008c0b2e93d443391883e9029afbcec3e73a8544;hpb=98688c6e8fd33f31c51218cf93cbf03fe3a5e73d;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/Linker.lhs b/ghc/compiler/ghci/Linker.lhs index 008c0b2..bb968ff 100644 --- a/ghc/compiler/ghci/Linker.lhs +++ b/ghc/compiler/ghci/Linker.lhs @@ -15,12 +15,11 @@ 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 "HsVersions.h" import ObjLink ( loadDLL, loadObj, unloadObj, resolveObjs, initObjLinker ) @@ -29,19 +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(..) ) @@ -105,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} @@ -138,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} @@ -183,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 @@ -214,7 +213,7 @@ reallyInitDynLinker ; lib_paths <- readIORef v_Library_paths ; cmdline_ld_inputs <- readIORef v_Ld_inputs - ; let (cmdline_libs, cmdline_objs) = partition libish cmdline_ld_inputs + ; classified_ld_inputs <- mapM classifyLdInput cmdline_ld_inputs -- (e) Link any MacOS frameworks #ifdef darwin_TARGET_OS @@ -225,8 +224,7 @@ reallyInitDynLinker ; let framework_paths = [] #endif -- Finally do (c),(d),(e) - ; let cmdline_lib_specs = map Object cmdline_objs - ++ map DLLPath cmdline_libs + ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ] ++ map DLL minus_ls ++ map Framework frameworks ; if null cmdline_lib_specs then return () @@ -240,16 +238,13 @@ reallyInitDynLinker else throwDyn (InstallationError "linking extra libraries/objects failed") }} -libish :: String -> Bool -libish f = getFileSuffix f `elem` dynlib_suffixes - -#ifdef mingw32_TARGET_OS -dynlib_suffixes = ["dll", "DLL"] -#elif defined(darwin_TARGET_OS) -dynlib_suffixes = ["dylib"] -#else -dynlib_suffixes = ["so"] -#endif +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 @@ -318,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 @@ -357,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 { @@ -374,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 @@ -384,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 @@ -406,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} @@ -464,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 @@ -473,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} @@ -645,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', @@ -708,7 +706,7 @@ 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 @@ -716,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 @@ -731,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 @@ -746,43 +744,54 @@ 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.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 - 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 @@ -794,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 @@ -811,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") -- ----------------------------------------------------------------------------