X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fghci%2FLinker.lhs;h=21a206490e66ebdb8ab6b1090d6e525f118e9329;hp=697cbc8d91e0751089da1827ae6c2af9ba1dd207;hb=703ca1542c8e0983cc9d8eebce6e9f3dd3fd71e2;hpb=5bbb7af7ff683e60d99aaad3b78da034bf80cbc7 diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 697cbc8..21a2064 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -14,12 +14,8 @@ 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 +{-# OPTIONS -fno-cse #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly module Linker ( HValue, getHValue, showLinkerState, linkExpr, unload, withExtendedLinkEnv, @@ -54,12 +50,10 @@ import ListSetOps 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 @@ -79,8 +73,9 @@ import System.FilePath import System.IO import System.Directory -import Control.Exception -import Data.Maybe +import Distribution.Package hiding (depends, PackageId) + +import Exception \end{code} @@ -127,7 +122,7 @@ data PersistentLinkerState } emptyPLS :: DynFlags -> PersistentLinkerState -emptyPLS dflags = PersistentLinkerState { +emptyPLS _ = PersistentLinkerState { closure_env = emptyNameEnv, itbl_env = emptyNameEnv, pkgs_loaded = init_pkgs, @@ -265,7 +260,7 @@ 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 "") + when (failed ok) $ ghcError (ProgramError "") pls <- readIORef v_PersistentLinkerState lookupName (closure_env pls) name @@ -291,16 +286,17 @@ linkDependencies hsc_env span needed_mods = do -- | 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 - 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 + liftIO $ writeIORef v_PersistentLinkerState new_pls return () -- Remember that the linker state might be side-effected @@ -308,7 +304,7 @@ withExtendedLinkEnv new_env action -- 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 = do + reset_old_env = liftIO $ do modifyIORef v_PersistentLinkerState $ \pls -> let cur = closure_env pls new = delListFromNameEnv cur (map fst new_env) @@ -375,6 +371,7 @@ initDynLinker dflags ; reallyInitDynLinker dflags } } +reallyInitDynLinker :: DynFlags -> IO () reallyInitDynLinker dflags = do { -- Initialise the linker state ; writeIORef v_PersistentLinkerState (emptyPLS dflags) @@ -414,7 +411,7 @@ reallyInitDynLinker 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) @@ -457,21 +454,20 @@ preloadLib dflags lib_paths framework_paths lib_spec 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} @@ -501,7 +497,7 @@ linkExpr hsc_env span root_ul_bco -- 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 @@ -526,7 +522,8 @@ linkExpr hsc_env span root_ul_bco -- 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) @@ -538,6 +535,7 @@ checkNonStdWay dflags srcspan = do 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") $$ @@ -551,7 +549,7 @@ getLinkDeps :: HscEnv -> HomePackageTable -> PackageIfaceTable -> 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 @@ -622,7 +620,7 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods 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"))) @@ -637,8 +635,7 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods 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... @@ -670,6 +667,7 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods 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} @@ -707,17 +705,16 @@ partitionLinkable li 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 = @@ -745,7 +742,7 @@ dynLinkObjs dflags objs 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 @@ -800,8 +797,8 @@ dynLinkBCOs bcos 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 } @@ -883,7 +880,7 @@ unload_wkr :: DynFlags -- 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) @@ -948,10 +945,13 @@ data LibrarySpec -- 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 @@ -995,7 +995,7 @@ linkPackages dflags new_pkgs ; return (new_pkg : pkgs') } | otherwise - = throwDyn (CmdLineError ("unknown package: " ++ packageIdString new_pkg)) + = ghcError (CmdLineError ("unknown package: " ++ packageIdString new_pkg)) linkPackage :: DynFlags -> PackageConfig -> IO () @@ -1024,7 +1024,7 @@ linkPackage dflags pkg 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 @@ -1045,14 +1045,16 @@ linkPackage dflags pkg 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 () @@ -1063,7 +1065,7 @@ loadFrameworks pkg 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. @@ -1079,14 +1081,14 @@ 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 ++ "-ghc" ++ cProjectVersion)) - Nothing -> return (DLL lib) }} -- We assume + 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 @@ -1094,12 +1096,14 @@ locateOneObj dirs lib Nothing -> return (DLL lib) }} -- We assume where mk_obj_path dir = dir (lib <.> "o") - mk_dyn_lib_path dir = dir mkSOName (lib ++ "-ghc" ++ cProjectVersion) + 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 @@ -1110,6 +1114,7 @@ loadDynamic paths rootname 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 @@ -1120,8 +1125,9 @@ mkSOName root -- 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"] @@ -1148,7 +1154,7 @@ loadFramework extraPaths rootname 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 @@ -1160,9 +1166,11 @@ findFile mk_file_path (dir:dirs) \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}