X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FLinker.lhs;h=fbef432a95ca21edc5a3128f80f849a81422696a;hb=0323459f422cc1cc62335f2ef5aac68d6896473b;hp=d44b22a496bc01297180ff93eaaeadc3b89b2d11;hpb=876db7eda26b37f988bda8f6da8616b03aa5f810;p=ghc-hetmet.git diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index d44b22a..fbef432 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,9 +61,11 @@ import StaticFlags import ErrUtils import DriverPhases import SrcLoc +import qualified Maybes import UniqSet import Constants import FastString +import Config ( cProjectVersion ) -- Standard libraries import Control.Monad @@ -65,6 +75,7 @@ import Data.IORef import Data.List import Foreign +import System.FilePath import System.IO import System.Directory @@ -163,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 @@ -219,13 +230,12 @@ dataConInfoPtrToName x = do -} getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8) - getConDescAddress ptr = do -#ifdef GHCI_TABLES_NEXT_TO_CODE + getConDescAddress ptr + | ghciTablesNextToCode = do offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE) return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord)) -#else + | otherwise = peek $ intPtrToPtr $ (ptrToIntPtr ptr) + fromIntegral stdInfoTableSizeB -#endif -- parsing names is a little bit fiddly because we have a string in the form: -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo"). @@ -386,13 +396,12 @@ reallyInitDynLinker dflags ; classified_ld_inputs <- mapM classifyLdInput cmdline_ld_inputs -- (e) Link any MacOS frameworks -#ifdef darwin_TARGET_OS - ; let framework_paths = frameworkPaths dflags - ; let frameworks = cmdlineFrameworks dflags -#else - ; let frameworks = [] - ; let framework_paths = [] -#endif + ; let framework_paths + | isDarwinTarget = frameworkPaths dflags + | otherwise = [] + ; let frameworks + | isDarwinTarget = cmdlineFrameworks dflags + | otherwise = [] -- Finally do (c),(d),(e) ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ] ++ map DLL minus_ls @@ -437,13 +446,14 @@ preloadLib dflags lib_paths framework_paths lib_spec Nothing -> maybePutStrLn dflags "done" Just mm -> preloadFailed mm lib_paths lib_spec -#ifdef darwin_TARGET_OS Framework framework + | isDarwinTarget -> do maybe_errstr <- loadFramework framework_paths framework case maybe_errstr of Nothing -> maybePutStrLn dflags "done" Just mm -> preloadFailed mm framework_paths lib_spec -#endif + | otherwise -> panic "preloadLib Framework" + where preloadFailed :: String -> [String] -> LibrarySpec -> IO () preloadFailed sys_errmsg paths spec @@ -529,9 +539,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 @@ -544,10 +554,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 ; @@ -576,29 +586,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 = @@ -606,18 +626,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 @@ -649,11 +663,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} @@ -935,11 +949,8 @@ data LibrarySpec -- used by lookupSymbol. So we must call addDLL for each library -- just to get the DLL handle into the list. partOfGHCi -# if defined(mingw32_TARGET_OS) || defined(darwin_TARGET_OS) - = [ ] -# else - = [ "base", "haskell98", "template-haskell", "readline" ] -# endif + | isWindowsTarget || isDarwinTarget = [] + | otherwise = [ "base", "haskell98", "template-haskell", "editline" ] showLS (Object nm) = "(static) " ++ nm showLS (DLL nm) = "(dynamic) " ++ nm @@ -1010,7 +1021,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 @@ -1034,17 +1045,17 @@ 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 Nothing -> return () Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: " ++ dll ++ " (" ++ err ++ ")" )) -#ifndef darwin_TARGET_OS -loadFrameworks pkg = return () -#else -loadFrameworks pkg = mapM_ load frameworks + +loadFrameworks pkg + | isDarwinTarget = mapM_ load frameworks + | otherwise = return () where fw_dirs = Packages.frameworkDirs pkg frameworks = Packages.frameworks pkg @@ -1054,24 +1065,36 @@ loadFrameworks pkg = mapM_ load frameworks Nothing -> return () Just err -> throwDyn (CmdLineError ("can't load framework: " ++ fw ++ " (" ++ err ++ ")" )) -#endif -- Try to find an object file for a given library in the given paths. -- If it isn't present, we assume it's a dynamic library. locateOneObj :: [FilePath] -> String -> IO LibrarySpec locateOneObj dirs lib + | not picIsOn + -- When the GHC package was not compiled as dynamic library + -- (=__PIC__ not set), we search for .o libraries first. = do { mb_obj_path <- findFile mk_obj_path dirs ; case mb_obj_path of Just obj_path -> return (Object obj_path) Nothing -> do { mb_lib_path <- findFile mk_dyn_lib_path dirs ; case mb_lib_path of - Just lib_path -> return (DLL (lib ++ "_dyn")) + Just lib_path -> return (DLL (lib ++ "-ghc" ++ cProjectVersion)) + Nothing -> return (DLL lib) }} -- We assume + | otherwise + -- When the GHC package was compiled as dynamic library (=__PIC__ set), + -- we search for .so libraries first. + = do { mb_lib_path <- findFile mk_dyn_lib_path dirs + ; case mb_lib_path of + Just lib_path -> return (DLL (lib ++ "-ghc" ++ cProjectVersion)) + Nothing -> + 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 where - mk_obj_path dir = dir `joinFileName` (lib `joinFileExt` "o") - mk_dyn_lib_path dir = dir `joinFileName` mkSOName (lib ++ "_dyn") - + mk_obj_path dir = dir (lib <.> "o") + mk_dyn_lib_path dir = dir mkSOName (lib ++ "-ghc" ++ cProjectVersion) -- ---------------------------------------------------------------------------- -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32) @@ -1085,34 +1108,34 @@ 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 - -#if defined(darwin_TARGET_OS) -mkSOName root = ("lib" ++ root) `joinFileExt` "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" -#endif + mk_dll_path dir = dir mkSOName rootname + +mkSOName root + | isDarwinTarget = ("lib" ++ root) <.> "dylib" + | isWindowsTarget = -- Win32 DLLs have no .dll extension here, because + -- addDLL tries both foo.dll and foo.drv + root + | otherwise = ("lib" ++ root) <.> "so" -- Darwin / MacOS X only: load a framework -- a framework is a dynamic library packaged inside a directory of the same -- 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} %************************************************************************