X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fghci%2FLinker.lhs;h=3bb208f695b40970f2e3a2ee31f5262a4ad57392;hp=afbd3b5ff898bca92b4d1b4042c36c93e1dd7518;hb=814d2f506d63f785dbfe33189dde606a06e60285;hpb=ab13303c49618c6224d7c5b5397ac9a98d2e5b6f diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index afbd3b5..3bb208f 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, @@ -40,7 +47,7 @@ import Name import NameEnv import NameSet import qualified OccName -import UniqFM +import LazyUniqFM import Module import ListSetOps import DynFlags @@ -55,17 +62,18 @@ import DriverPhases import SrcLoc import UniqSet import Constants +import FastString +import Config ( cProjectVersion ) -- Standard libraries import Control.Monad +import Data.Char import Data.IORef import Data.List -import Foreign.Ptr -import Foreign.C.Types -import Foreign.C.String -import Foreign.Storable +import Foreign +import System.FilePath import System.IO import System.Directory @@ -152,26 +160,30 @@ deleteFromLinkEnv to_remove new_pls = pls { closure_env = new_closure_env } writeIORef v_PersistentLinkerState new_pls --- | Given a data constructor, find its internal name. --- The info tables for data constructors have a field which records the source name --- of the constructor as a CString. The format is: +-- | Given a data constructor in the heap, find its Name. +-- The info tables for data constructors have a field which records +-- the source name of the constructor as a Ptr Word8 (UTF-8 encoded +-- string). The format is: -- -- Package:Module.Name -- -- We use this string to lookup the interpreter's internal representation of the name -- using the lookupOrig. -dataConInfoPtrToName :: Ptr () -> TcM Name +dataConInfoPtrToName :: Ptr () -> TcM (Either String Name) dataConInfoPtrToName x = do - theString <- ioToTcRn $ do + theString <- liftIO $ do let ptr = castPtr x :: Ptr StgInfoTable conDescAddress <- getConDescAddress ptr - str <- peekCString conDescAddress - return str + peekArray0 0 conDescAddress let (pkg, mod, occ) = parse theString - occName = mkOccName OccName.dataName occ - modName = mkModule (stringToPackageId pkg) (mkModuleName mod) - lookupOrig modName occName + pkgFS = mkFastStringByteList pkg + modFS = mkFastStringByteList mod + occFS = mkFastStringByteList occ + occName = mkOccNameFS OccName.dataName occFS + modName = mkModule (fsToPackageId pkgFS) (mkModuleNameFS modFS) + return (Left$ showSDoc$ ppr modName <> dot <> ppr occName ) + `recoverM` (Right `fmap` lookupOrig modName occName) where @@ -215,13 +227,13 @@ dataConInfoPtrToName x = do in the memory location: info_table_ptr + info_table_size -} - getConDescAddress :: Ptr StgInfoTable -> IO (Ptr CChar) + getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8) getConDescAddress ptr = do #ifdef GHCI_TABLES_NEXT_TO_CODE offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE) return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord)) #else - peek $ intPtrToPtr $ (ptrToIntPtr ptr) + stdInfoTableSizeB + peek $ intPtrToPtr $ (ptrToIntPtr ptr) + fromIntegral stdInfoTableSizeB #endif -- parsing names is a little bit fiddly because we have a string in the form: @@ -231,20 +243,21 @@ dataConInfoPtrToName x = do -- this is not the conventional way of writing Haskell names. We stick with -- convention, even though it makes the parsing code more troublesome. -- Warning: this code assumes that the string is well formed. - parse :: String -> (String, String, String) + parse :: [Word8] -> ([Word8], [Word8], [Word8]) parse input = ASSERT (all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ) where - (pkg, rest1) = break (==':') input + dot = fromIntegral (ord '.') + (pkg, rest1) = break (== fromIntegral (ord ':')) input (mod, occ) - = (concat $ intersperse "." $ reverse modWords, occWord) + = (concat $ intersperse [dot] $ reverse modWords, occWord) where (modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1)) - parseModOcc :: [String] -> String -> ([String], String) + parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8]) parseModOcc acc str - = case break (== '.') str of + = case break (== dot) str of (top, []) -> (acc, top) - (top, '.':bot) -> parseModOcc (top : acc) bot + (top, _:bot) -> parseModOcc (top : acc) bot getHValue :: HscEnv -> Name -> IO HValue @@ -275,17 +288,31 @@ linkDependencies hsc_env span needed_mods = do linkModules dflags lnks +-- | Temporarily extend the linker state. + withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a withExtendedLinkEnv new_env action = bracket set_new_env reset_old_env (const action) - where set_new_env = do pls <- readIORef v_PersistentLinkerState - let new_closure_env = extendClosureEnv (closure_env pls) new_env - new_pls = pls { closure_env = new_closure_env } - writeIORef v_PersistentLinkerState new_pls - return (closure_env pls) - reset_old_env env = modifyIORef v_PersistentLinkerState (\pls -> pls{ closure_env = env }) + where set_new_env = do + pls <- readIORef v_PersistentLinkerState + let new_closure_env = extendClosureEnv (closure_env pls) new_env + new_pls = pls { closure_env = new_closure_env } + writeIORef v_PersistentLinkerState new_pls + return (closure_env pls) + + -- Remember that the linker state might be side-effected + -- during the execution of the IO action, and we don't want to + -- lose those changes (we might have linked a new module or + -- package), so the reset action only removes the names we + -- added earlier. + reset_old_env env = do + modifyIORef v_PersistentLinkerState $ \pls -> + let cur = closure_env pls + new = delListFromNameEnv cur (map fst new_env) + in + pls{ closure_env = new } -- filterNameMap removes from the environment all entries except -- those for a given set of modules; @@ -511,9 +538,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 @@ -591,15 +618,15 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods 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 + 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 @@ -631,11 +658,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} @@ -920,7 +947,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 @@ -992,7 +1019,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 @@ -1016,7 +1043,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 @@ -1040,6 +1067,9 @@ loadFrameworks pkg = mapM_ load frameworks -- 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. +#ifndef __PIC__ +-- When the GHC package was not compiled as dynamic library (=__PIC__ not set), +-- we search for .o libraries first. locateOneObj :: [FilePath] -> String -> IO LibrarySpec locateOneObj dirs lib = do { mb_obj_path <- findFile mk_obj_path dirs @@ -1048,12 +1078,28 @@ locateOneObj dirs lib 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 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) +#else +-- When the GHC package was compiled as dynamic library (=__PIC__ set), +-- we search for .so libraries first. +locateOneObj :: [FilePath] -> String -> IO LibrarySpec +locateOneObj dirs lib + = 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 (lib <.> "o") + mk_dyn_lib_path dir = dir mkSOName (lib ++ "-ghc" ++ cProjectVersion) +#endif -- ---------------------------------------------------------------------------- -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32) @@ -1067,16 +1113,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 @@ -1084,15 +1130,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}