\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
+{-# OPTIONS -fno-cse #-}
+-- -fno-cse is needed for GLOBAL_VAR's to behave properly
module Linker ( HValue, getHValue, showLinkerState,
linkExpr, unload, withExtendedLinkEnv,
import DynFlags
import BasicTypes
import Outputable
-import PackageConfig
import Panic
import Util
import StaticFlags
import ErrUtils
-import DriverPhases
import SrcLoc
import qualified Maybes
import UniqSet
import System.IO
import System.Directory
-import Control.Exception
-import Data.Maybe
+import Distribution.Package hiding (depends, PackageId)
+
+import Exception
\end{code}
}
emptyPLS :: DynFlags -> PersistentLinkerState
-emptyPLS dflags = PersistentLinkerState {
+emptyPLS _ = PersistentLinkerState {
closure_env = emptyNameEnv,
itbl_env = emptyNameEnv,
pkgs_loaded = init_pkgs,
getHValue hsc_env name = do
when (isExternalName name) $ do
ok <- linkDependencies hsc_env noSrcSpan [nameModule name]
- when (failed ok) $ throwDyn (ProgramError "")
+ when (failed ok) $ ghcError (ProgramError "")
pls <- readIORef v_PersistentLinkerState
lookupName (closure_env pls) name
-- | Temporarily extend the linker state.
-withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a
+withExtendedLinkEnv :: (MonadIO m, ExceptionMonad m) =>
+ [(Name,HValue)] -> m a -> m a
withExtendedLinkEnv new_env action
- = bracket set_new_env
- reset_old_env
- (const action)
+ = gbracket set_new_env
+ (\_ -> reset_old_env)
+ (\_ -> action)
where set_new_env = do
- pls <- readIORef v_PersistentLinkerState
+ pls <- liftIO $ 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)
+ liftIO $ writeIORef v_PersistentLinkerState new_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 = liftIO $ do
modifyIORef v_PersistentLinkerState $ \pls ->
let cur = closure_env pls
new = delListFromNameEnv cur (map fst new_env)
; reallyInitDynLinker dflags }
}
+reallyInitDynLinker :: DynFlags -> IO ()
reallyInitDynLinker dflags
= do { -- Initialise the linker state
; writeIORef v_PersistentLinkerState (emptyPLS dflags)
; ok <- resolveObjs
; if succeeded ok then maybePutStrLn dflags "done"
- else throwDyn (InstallationError "linking extra libraries/objects failed")
+ else ghcError (ProgramError "linking extra libraries/objects failed")
}}
classifyLdInput :: FilePath -> IO (Maybe LibrarySpec)
where
preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
preloadFailed sys_errmsg paths spec
- = do maybePutStr dflags
- ("failed.\nDynamic linker error message was:\n "
- ++ sys_errmsg ++ "\nWhilst trying to load: "
- ++ showLS spec ++ "\nDirectories to search are:\n"
- ++ unlines (map (" "++) paths) )
- give_up
+ = do maybePutStr dflags "failed.\n"
+ ghcError $
+ CmdLineError (
+ "user specified .o/.so/.DLL could not be loaded ("
+ ++ sys_errmsg ++ ")\nWhilst trying to load: "
+ ++ showLS spec ++ "\nAdditional directories searched:"
+ ++ (if null paths then " (none)" else
+ (concat (intersperse "\n" (map (" "++) paths)))))
-- Not interested in the paths in the static case.
- preload_static paths name
+ preload_static _paths name
= do b <- doesFileExist name
if not b then return False
else loadObj name >> return True
-
- give_up = throwDyn $
- CmdLineError "user specified .o/.so/.DLL could not be loaded."
\end{code}
-- Link the packages and modules required
; ok <- linkDependencies hsc_env span needed_mods
; if failed ok then
- throwDyn (ProgramError "")
+ ghcError (ProgramError "")
else do {
-- Link the expression itself
-- All wired-in names are in the base package, which we link
-- by default, so we can safely ignore them here.
-dieWith span msg = throwDyn (ProgramError (showSDoc (mkLocMessage span msg)))
+dieWith :: SrcSpan -> Message -> IO a
+dieWith span msg = ghcError (ProgramError (showSDoc (mkLocMessage span msg)))
checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe String)
then failNonStd srcspan
else return (Just default_osuf)
+failNonStd :: SrcSpan -> IO (Maybe String)
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") $$
-> IO ([Linkable], [PackageId]) -- ... then link these first
-- Fails with an IO exception if it can't find enough files
-getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods
+getLinkDeps hsc_env hpt _ maybe_normal_osuf span mods
-- Find all the packages and linkables that a set of modules depends on
= do { pls <- readIORef v_PersistentLinkerState ;
-- 1. Find the dependent home-pkg-modules/packages from each iface
link_boot_mod_error mod =
- throwDyn (ProgramError (showSDoc (
+ ghcError (ProgramError (showSDoc (
text "module" <+> ppr mod <+>
text "cannot be linked; it is only available as a boot module")))
get_linkable maybe_normal_osuf mod_name -- A home-package module
| Just mod_info <- lookupUFM hpt mod_name
- = ASSERT(isJust (hm_linkable mod_info))
- adjust_linkable (fromJust (hm_linkable mod_info))
+ = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))
| otherwise
= do -- It's not in the HPT because we are in one shot mode,
-- so use the Finder to get a ModLocation...
ptext (sLit "cannot find normal object file ")
<> quotes (text new_file) $$ while_linking_expr
else return (DotO new_file)
+ adjust_ul _ _ = panic "adjust_ul"
\end{code}
li_uls_bco = filter isInterpretable li_uls
in
case (li_uls_obj, li_uls_bco) of
- (objs@(_:_), bcos@(_:_))
- -> [li{linkableUnlinked=li_uls_obj}, li{linkableUnlinked=li_uls_bco}]
- other
- -> [li]
+ (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj},
+ li {linkableUnlinked=li_uls_bco}]
+ _ -> [li]
findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
findModuleLinkable_maybe lis mod
= case [LM time nm us | LM time nm us <- lis, nm == mod] of
[] -> Nothing
[li] -> Just li
- many -> pprPanic "findModuleLinkable" (ppr mod)
+ _ -> pprPanic "findModuleLinkable" (ppr mod)
linkableInSet :: Linkable -> [Linkable] -> Bool
linkableInSet l objs_loaded =
pls1 = pls { objs_loaded = objs_loaded' }
unlinkeds = concatMap linkableUnlinked new_objs
- mapM loadObj (map nameOfObject unlinkeds)
+ mapM_ loadObj (map nameOfObject unlinkeds)
-- Link the all together
ok <- resolveObjs
gce = closure_env pls
final_ie = foldr plusNameEnv (itbl_env pls) ies
- (final_gce, linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos
- -- What happens to these linked_bcos?
+ (final_gce, _linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos
+ -- XXX What happens to these linked_bcos?
let pls2 = pls1 { closure_env = final_gce,
itbl_env = final_ie }
-- Does the core unload business
-- (the wrapper blocks exceptions and deals with the PLS get and put)
-unload_wkr dflags linkables pls
+unload_wkr _ linkables pls
= do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls)
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
-- of DLL handles that rts/Linker.c maintains, and that in turn is
-- used by lookupSymbol. So we must call addDLL for each library
-- just to get the DLL handle into the list.
+partOfGHCi :: [PackageName]
partOfGHCi
| isWindowsTarget || isDarwinTarget = []
- | otherwise = [ "base", "haskell98", "template-haskell", "editline" ]
+ | otherwise = map PackageName
+ ["base", "haskell98", "template-haskell", "editline"]
+showLS :: LibrarySpec -> String
showLS (Object nm) = "(static) " ++ nm
showLS (DLL nm) = "(dynamic) " ++ nm
showLS (DLLPath nm) = "(dynamic) " ++ nm
; return (new_pkg : pkgs') }
| otherwise
- = throwDyn (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
+ = ghcError (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
linkPackage :: DynFlags -> PackageConfig -> IO ()
maybePutStr dflags ("Loading package " ++ display (package pkg) ++ " ... ")
-- See comments with partOfGHCi
- when (pkgName (package pkg) `notElem` partOfGHCi) $ do
+ when (packageName pkg `notElem` partOfGHCi) $ do
loadFrameworks pkg
-- When a library A needs symbols from a library B, the order in
-- extra_libraries/extra_ld_opts is "-lA -lB", because that's the
maybePutStr dflags "linking ... "
ok <- resolveObjs
if succeeded ok then maybePutStrLn dflags "done."
- else throwDyn (InstallationError ("unable to load package `" ++ display (package pkg) ++ "'"))
+ else ghcError (InstallationError ("unable to load package `" ++ display (package pkg) ++ "'"))
+load_dyn :: [FilePath] -> FilePath -> IO ()
load_dyn dirs dll = do r <- loadDynamic dirs dll
case r of
Nothing -> return ()
- Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: "
+ Just err -> ghcError (CmdLineError ("can't load .so/.DLL for: "
++ dll ++ " (" ++ err ++ ")" ))
+loadFrameworks :: InstalledPackageInfo_ ModuleName -> IO ()
loadFrameworks pkg
| isDarwinTarget = mapM_ load frameworks
| otherwise = return ()
load fw = do r <- loadFramework fw_dirs fw
case r of
Nothing -> return ()
- Just err -> throwDyn (CmdLineError ("can't load framework: "
+ Just err -> ghcError (CmdLineError ("can't load framework: "
++ fw ++ " (" ++ err ++ ")" ))
-- 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)
Nothing ->
do { mb_lib_path <- findFile mk_dyn_lib_path dirs
; 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
+ Just _ -> return (DLL dyn_lib_name)
+ 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))
+ Just _ -> return (DLL (lib ++ "-ghc" ++ cProjectVersion))
Nothing ->
do { mb_obj_path <- findFile mk_obj_path dirs
; case mb_obj_path of
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
+ dyn_lib_name = lib ++ "-ghc" ++ cProjectVersion
+ mk_dyn_lib_path dir = dir </> mkSOName dyn_lib_name
-- ----------------------------------------------------------------------------
-- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
-- return Nothing == success, else Just error message from dlopen
+loadDynamic :: [FilePath] -> FilePath -> IO (Maybe String)
loadDynamic paths rootname
= do { mb_dll <- findFile mk_dll_path paths
; case mb_dll of
where
mk_dll_path dir = dir </> mkSOName rootname
+mkSOName :: FilePath -> FilePath
mkSOName root
| isDarwinTarget = ("lib" ++ root) <.> "dylib"
| isWindowsTarget = -- Win32 DLLs have no .dll extension here, because
-- 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.
+loadFramework :: [FilePath] -> FilePath -> IO (Maybe String)
loadFramework extraPaths rootname
- = do { either_dir <- Control.Exception.try getHomeDirectory
+ = do { either_dir <- tryIO getHomeDirectory
; let homeFrameworkPath = case either_dir of
Left _ -> []
Right dir -> [dir ++ "/Library/Frameworks"]
findFile :: (FilePath -> FilePath) -- Maps a directory path to a file path
-> [FilePath] -- Directories to look in
-> IO (Maybe FilePath) -- The first file path to match
-findFile mk_file_path []
+findFile _ []
= return Nothing
findFile mk_file_path (dir:dirs)
= do { let file_path = mk_file_path dir
\end{code}
\begin{code}
+maybePutStr :: DynFlags -> String -> IO ()
maybePutStr dflags s | verbosity dflags > 0 = putStr s
| otherwise = return ()
+maybePutStrLn :: DynFlags -> String -> IO ()
maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
| otherwise = return ()
\end{code}
projects / ghc-hetmet.git / blobdiff