\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, extendLinkEnv, withExtendedLinkEnv,
- extendLoadedPkgs,
+ linkExpr, unload, withExtendedLinkEnv,
+ extendLinkEnv, deleteFromLinkEnv,
+ extendLoadedPkgs,
linkPackages,initDynLinker,
- recoverDataCon
+ dataConInfoPtrToName
) where
#include "HsVersions.h"
+import LoadIface
import ObjLink
import ByteCodeLink
import ByteCodeItbls
import ByteCodeAsm
-import RtClosureInspect
+import CgInfoTbls
+import SMRep
import IfaceEnv
-import OccName
import TcRnMonad
import Packages
import DriverPhases
import Name
import NameEnv
import NameSet
-import UniqFM
+import qualified OccName
+import LazyUniqFM
import Module
import ListSetOps
import DynFlags
import ErrUtils
import DriverPhases
import SrcLoc
+import qualified Maybes
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
import Control.Exception
import Data.Maybe
-
-#if __GLASGOW_HASKELL__ >= 503
-import GHC.IOBase ( IO(..) )
-#else
-import PrelIOBase ( IO(..) )
-#endif
-
\end{code}
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:
+deleteFromLinkEnv :: [Name] -> IO ()
+deleteFromLinkEnv to_remove
+ = do pls <- readIORef v_PersistentLinkerState
+ let new_closure_env = delListFromNameEnv (closure_env pls) to_remove
+ new_pls = pls { closure_env = new_closure_env }
+ writeIORef v_PersistentLinkerState new_pls
+
+-- | 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.
-recoverDataCon :: a -> TcM Name
-recoverDataCon x = do
- theString <- ioToTcRn $ do
- let ptr = getInfoTablePtr x
+dataConInfoPtrToName :: Ptr () -> TcM (Either String Name)
+dataConInfoPtrToName x = do
+ theString <- liftIO $ do
+ let ptr = castPtr x :: Ptr StgInfoTable
conDescAddress <- getConDescAddress ptr
- peekCString conDescAddress
+ 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
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 $ intPtrToPtr $ (ptrToIntPtr ptr) + offset
- return $ ptr `plusPtr` offsetToString
- where
- -- subtract a word number of bytes
- offset = negate (fromIntegral SIZEOF_VOID_P)
-#endif
-#ifndef GHCI_TABLES_NEXT_TO_CODE
- peek $ intPtrToPtr $ (ptrToIntPtr ptr) + offset
- where
- -- add the standard info table size in bytes
- infoTableSizeBytes = sTD_ITBL_SIZE * wORD_SIZE
- offset = infoTableSizeBytes
+ offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE)
+ return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord))
+#else
+ peek $ intPtrToPtr $ (ptrToIntPtr ptr) + fromIntegral stdInfoTableSizeB
#endif
-- parsing names is a little bit fiddly because we have a string in the form:
-- 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 :: Name -> IO (Maybe HValue)
-getHValue name = do
- pls <- readIORef v_PersistentLinkerState
- case lookupNameEnv (closure_env pls) name of
- Just (_,x) -> return$ Just x
- _ -> return Nothing
+getHValue :: HscEnv -> Name -> IO HValue
+getHValue hsc_env name = do
+ when (isExternalName name) $ do
+ ok <- linkDependencies hsc_env noSrcSpan [nameModule name]
+ when (failed ok) $ throwDyn (ProgramError "")
+ pls <- readIORef v_PersistentLinkerState
+ lookupName (closure_env pls) name
+
+linkDependencies :: HscEnv -> SrcSpan -> [Module] -> IO SuccessFlag
+linkDependencies hsc_env span needed_mods = do
+ let hpt = hsc_HPT hsc_env
+ dflags = hsc_dflags hsc_env
+ -- The interpreter and dynamic linker can only handle object code built
+ -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
+ -- So here we check the build tag: if we're building a non-standard way
+ -- then we need to find & link object files built the "normal" way.
+ maybe_normal_osuf <- checkNonStdWay dflags span
+
+ -- Find what packages and linkables are required
+ eps <- readIORef (hsc_EPS hsc_env)
+ (lnks, pkgs) <- getLinkDeps hsc_env hpt (eps_PIT eps)
+ maybe_normal_osuf span needed_mods
+
+ -- Link the packages and modules required
+ linkPackages dflags pkgs
+ 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;
let dflags = hsc_dflags hsc_env
; initDynLinker dflags
- -- The interpreter and dynamic linker can only handle object code built
- -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
- -- So here we check the build tag: if we're building a non-standard way
- -- then we need to find & link object files built the "normal" way.
- ; maybe_normal_osuf <- checkNonStdWay dflags span
-
- -- Find what packages and linkables are required
- ; eps <- readIORef (hsc_EPS hsc_env)
- ; (lnks, pkgs) <- getLinkDeps hsc_env hpt (eps_PIT eps)
- maybe_normal_osuf span needed_mods
-
-- Link the packages and modules required
- ; linkPackages dflags pkgs
- ; ok <- linkModules dflags lnks
+ ; ok <- linkDependencies hsc_env span needed_mods
; if failed ok then
throwDyn (ProgramError "")
else do {
; return root_hval
}}
where
- hpt = hsc_HPT hsc_env
free_names = nameSetToList (bcoFreeNames root_ul_bco)
needed_mods :: [Module]
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
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 ;
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 =
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
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}
# 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
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
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
-- 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
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)
-- 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
-- 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}