X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fghci%2FLinker.lhs;h=ad90900422b33e2f4e11a8196ff0335a65fa68b4;hp=70af5f26e868d670e0a568c5fc94e415a3ec0af6;hb=b7fecf522f271305de84d0efe8af5cad28aa45f5;hpb=ca9e6d1e1d759fd20f23e6ab24859b812991fca7 diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 70af5f2..ad90900 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -14,6 +14,13 @@ necessary. \begin{code} {-# OPTIONS -optc-DNON_POSIX_SOURCE -#include "Linker.h" #-} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module Linker ( HValue, getHValue, showLinkerState, linkExpr, unload, withExtendedLinkEnv, extendLinkEnv, deleteFromLinkEnv, @@ -24,6 +31,7 @@ module Linker ( HValue, getHValue, showLinkerState, #include "HsVersions.h" +import LoadIface import ObjLink import ByteCodeLink import ByteCodeItbls @@ -40,7 +48,7 @@ import Name import NameEnv import NameSet import qualified OccName -import UniqFM +import LazyUniqFM import Module import ListSetOps import DynFlags @@ -53,6 +61,7 @@ import StaticFlags import ErrUtils import DriverPhases import SrcLoc +import qualified Maybes import UniqSet import Constants import FastString @@ -66,6 +75,7 @@ import Data.IORef import Data.List import Foreign +import System.FilePath import System.IO import System.Directory @@ -164,7 +174,7 @@ deleteFromLinkEnv to_remove dataConInfoPtrToName :: Ptr () -> TcM (Either String Name) dataConInfoPtrToName x = do - theString <- ioToTcRn $ do + theString <- liftIO $ do let ptr = castPtr x :: Ptr StgInfoTable conDescAddress <- getConDescAddress ptr peekArray0 0 conDescAddress @@ -530,9 +540,9 @@ checkNonStdWay dflags srcspan = do else return (Just default_osuf) failNonStd srcspan = dieWith srcspan $ - ptext SLIT("Dynamic linking required, but this is a non-standard build (eg. prof).") $$ - ptext SLIT("You need to build the program twice: once the normal way, and then") $$ - ptext SLIT("in the desired way using -osuf to set the object file suffix.") + ptext (sLit "Dynamic linking required, but this is a non-standard build (eg. prof).") $$ + ptext (sLit "You need to build the program twice: once the normal way, and then") $$ + ptext (sLit "in the desired way using -osuf to set the object file suffix.") getLinkDeps :: HscEnv -> HomePackageTable -> PackageIfaceTable @@ -545,10 +555,10 @@ getLinkDeps :: HscEnv -> HomePackageTable -> PackageIfaceTable getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods -- Find all the packages and linkables that a set of modules depends on = do { pls <- readIORef v_PersistentLinkerState ; - let { -- 1. Find the dependent home-pkg-modules/packages from each iface - (mods_s, pkgs_s) = follow_deps mods emptyUniqSet emptyUniqSet; + (mods_s, pkgs_s) <- follow_deps mods emptyUniqSet emptyUniqSet; + let { -- 2. Exclude ones already linked -- Main reason: avoid findModule calls in get_linkable mods_needed = mods_s `minusList` linked_mods ; @@ -577,29 +587,39 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods follow_deps :: [Module] -- modules to follow -> UniqSet ModuleName -- accum. module dependencies -> UniqSet PackageId -- accum. package dependencies - -> ([ModuleName], [PackageId]) -- result + -> IO ([ModuleName], [PackageId]) -- result follow_deps [] acc_mods acc_pkgs - = (uniqSetToList acc_mods, uniqSetToList acc_pkgs) + = return (uniqSetToList acc_mods, uniqSetToList acc_pkgs) follow_deps (mod:mods) acc_mods acc_pkgs - | pkg /= this_pkg - = follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg) - | mi_boot iface - = link_boot_mod_error mod - | otherwise - = follow_deps (map (mkModule this_pkg) boot_deps' ++ mods) acc_mods' acc_pkgs' - where - pkg = modulePackageId mod - iface = get_iface mod - deps = mi_deps iface - - pkg_deps = dep_pkgs deps - (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps) - where is_boot (m,True) = Left m - is_boot (m,False) = Right m - - boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps - acc_mods' = addListToUniqSet acc_mods (moduleName mod : mod_deps) - acc_pkgs' = addListToUniqSet acc_pkgs pkg_deps + = do + mb_iface <- initIfaceCheck hsc_env $ + loadInterface msg mod (ImportByUser False) + iface <- case mb_iface of + Maybes.Failed err -> ghcError (ProgramError (showSDoc err)) + Maybes.Succeeded iface -> return iface + + when (mi_boot iface) $ link_boot_mod_error mod + + let + pkg = modulePackageId mod + deps = mi_deps iface + + pkg_deps = dep_pkgs deps + (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps) + where is_boot (m,True) = Left m + is_boot (m,False) = Right m + + boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps + acc_mods' = addListToUniqSet acc_mods (moduleName mod : mod_deps) + acc_pkgs' = addListToUniqSet acc_pkgs pkg_deps + -- + if pkg /= this_pkg + then follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg) + else follow_deps (map (mkModule this_pkg) boot_deps' ++ mods) + acc_mods' acc_pkgs' + where + msg = text "need to link module" <+> ppr mod <+> + text "due to use of Template Haskell" link_boot_mod_error mod = @@ -607,18 +627,12 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods text "module" <+> ppr mod <+> text "cannot be linked; it is only available as a boot module"))) - get_iface mod = case lookupIfaceByModule dflags hpt pit mod of - Just iface -> iface - Nothing -> pprPanic "getLinkDeps" (no_iface mod) - no_iface mod = ptext SLIT("No iface for") <+> ppr mod - -- This one is a GHC bug - no_obj mod = dieWith span $ - ptext SLIT("cannot find object file for module ") <> + ptext (sLit "cannot find object file for module ") <> quotes (ppr mod) $$ while_linking_expr - while_linking_expr = ptext SLIT("while linking an interpreted expression") + while_linking_expr = ptext (sLit "while linking an interpreted expression") -- This one is a build-system bug @@ -650,11 +664,11 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods return lnk adjust_ul osuf (DotO file) = do - let new_file = replaceFilenameSuffix file osuf + let new_file = replaceExtension file osuf ok <- doesFileExist new_file if (not ok) then dieWith span $ - ptext SLIT("cannot find normal object file ") + ptext (sLit "cannot find normal object file ") <> quotes (text new_file) $$ while_linking_expr else return (DotO new_file) \end{code} @@ -939,7 +953,7 @@ partOfGHCi # if defined(mingw32_TARGET_OS) || defined(darwin_TARGET_OS) = [ ] # else - = [ "base", "haskell98", "template-haskell", "readline" ] + = [ "base", "haskell98", "template-haskell", "editline" ] # endif showLS (Object nm) = "(static) " ++ nm @@ -1011,7 +1025,7 @@ linkPackage dflags pkg let dlls = [ dll | DLL dll <- classifieds ] objs = [ obj | Object obj <- classifieds ] - maybePutStr dflags ("Loading package " ++ showPackageId (package pkg) ++ " ... ") + maybePutStr dflags ("Loading package " ++ display (package pkg) ++ " ... ") -- See comments with partOfGHCi when (pkgName (package pkg) `notElem` partOfGHCi) $ do @@ -1035,7 +1049,7 @@ linkPackage dflags pkg maybePutStr dflags "linking ... " ok <- resolveObjs if succeeded ok then maybePutStrLn dflags "done." - else throwDyn (InstallationError ("unable to load package `" ++ showPackageId (package pkg) ++ "'")) + else throwDyn (InstallationError ("unable to load package `" ++ display (package pkg) ++ "'")) load_dyn dirs dll = do r <- loadDynamic dirs dll case r of @@ -1073,8 +1087,8 @@ locateOneObj dirs lib Just lib_path -> return (DLL (lib ++ "-ghc" ++ cProjectVersion)) Nothing -> return (DLL lib) }} -- We assume where - mk_obj_path dir = dir `joinFileName` (lib `joinFileExt` "o") - mk_dyn_lib_path dir = dir `joinFileName` mkSOName (lib ++ "-ghc" ++ cProjectVersion) + mk_obj_path dir = dir lib <.> "o" + mk_dyn_lib_path dir = dir mkSOName (lib ++ "-ghc" ++ cProjectVersion) #else -- When the GHC package was compiled as dynamic library (=__PIC__ set), -- we search for .so libraries first. @@ -1089,8 +1103,8 @@ locateOneObj dirs lib Just obj_path -> return (Object obj_path) Nothing -> return (DLL lib) }} -- We assume where - mk_obj_path dir = dir `joinFileName` (lib `joinFileExt` "o") - mk_dyn_lib_path dir = dir `joinFileName` mkSOName (lib ++ "-ghc" ++ cProjectVersion) + mk_obj_path dir = dir (lib <.> "o") + mk_dyn_lib_path dir = dir mkSOName (lib ++ "-ghc" ++ cProjectVersion) #endif -- ---------------------------------------------------------------------------- @@ -1105,16 +1119,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 `joinFileName` mkSOName rootname + mk_dll_path dir = dir mkSOName rootname #if defined(darwin_TARGET_OS) -mkSOName root = ("lib" ++ root) `joinFileExt` "dylib" +mkSOName root = ("lib" ++ root) <.> "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) `joinFileExt` "so" +mkSOName root = ("lib" ++ root) <.> "so" #endif -- Darwin / MacOS X only: load a framework @@ -1122,15 +1136,20 @@ mkSOName root = ("lib" ++ root) `joinFileExt` "so" -- name. They are searched for in different paths than normal libraries. #ifdef darwin_TARGET_OS loadFramework extraPaths rootname - = do { mb_fwk <- findFile mk_fwk (extraPaths ++ defaultFrameworkPaths) - ; case mb_fwk of - Just fwk_path -> loadDLL fwk_path - Nothing -> return (Just "not found") } - -- Tried all our known library paths, but dlopen() - -- has no built-in paths for frameworks: give up + = do { either_dir <- Control.Exception.try getHomeDirectory + ; let homeFrameworkPath = case either_dir of + Left _ -> [] + Right dir -> [dir ++ "/Library/Frameworks"] + ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths + ; mb_fwk <- findFile mk_fwk ps + ; case mb_fwk of + Just fwk_path -> loadDLL fwk_path + Nothing -> return (Just "not found") } + -- Tried all our known library paths, but dlopen() + -- has no built-in paths for frameworks: give up where - mk_fwk dir = dir `joinFileName` (rootname ++ ".framework/" ++ rootname) - -- sorry for the hardcoded paths, I hope they won't change anytime soon: + mk_fwk dir = dir (rootname ++ ".framework/" ++ rootname) + -- sorry for the hardcoded paths, I hope they won't change anytime soon: defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"] #endif \end{code}