#include "HsVersions.h"
+import LoadIface
import ObjLink
import ByteCodeLink
import ByteCodeItbls
import ErrUtils
import DriverPhases
import SrcLoc
+import qualified Maybes
import UniqSet
import Constants
import FastString
-}
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").
withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a
withExtendedLinkEnv new_env action
- = bracket set_new_env
- reset_old_env
- (const action)
+ = bracket_ set_new_env
+ reset_old_env
+ 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)
+ return ()
-- 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
+ reset_old_env = do
modifyIORef v_PersistentLinkerState $ \pls ->
let cur = closure_env pls
new = delListFromNameEnv cur (map fst new_env)
; 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
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
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
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}
where
maybeUnload :: [Linkable] -> Linkable -> IO Bool
maybeUnload keep_linkables lnk
- | linkableInSet lnk linkables = return True
+ | linkableInSet lnk keep_linkables = return True
| otherwise
= do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk]
-- The components of a BCO linkable may contain
-- 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
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
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
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.
-#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
+ | 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)
; case mb_lib_path of
Just lib_path -> return (DLL (lib ++ "-ghc" ++ cProjectVersion))
Nothing -> return (DLL lib) }} -- We assume
- where
- 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
+ | 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))
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)
where
mk_dll_path dir = dir </> mkSOName rootname
-#if defined(darwin_TARGET_OS)
-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) <.> "so"
-#endif
+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 { either_dir <- Control.Exception.try getHomeDirectory
; let homeFrameworkPath = case either_dir of
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}
%************************************************************************