#include "HsVersions.h"
+import LoadIface
import ObjLink
import ByteCodeLink
import ByteCodeItbls
import NameEnv
import NameSet
import qualified OccName
-import UniqFM
+import LazyUniqFM
import Module
import ListSetOps
import DynFlags
import ErrUtils
import DriverPhases
import SrcLoc
+import qualified Maybes
import UniqSet
import Constants
import FastString
import Data.List
import Foreign
+import System.FilePath
import System.IO
import System.Directory
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
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
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.
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
-- ----------------------------------------------------------------------------
-- 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}
projects / ghc-hetmet.git / blobdiff