X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fghci%2FLinker.lhs;h=21a206490e66ebdb8ab6b1090d6e525f118e9329;hp=ac92975259b451ea1f942e7edded4764d49725a4;hb=703ca1542c8e0983cc9d8eebce6e9f3dd3fd71e2;hpb=a11bb49b97eaba892730baf1565e922715dbc07f diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index ac92975..21a2064 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -14,6 +14,9 @@ necessary. \begin{code} {-# OPTIONS -optc-DNON_POSIX_SOURCE -#include "Linker.h" #-} +{-# OPTIONS -fno-cse #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly + module Linker ( HValue, getHValue, showLinkerState, linkExpr, unload, withExtendedLinkEnv, extendLinkEnv, deleteFromLinkEnv, @@ -47,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 @@ -72,10 +73,9 @@ import System.FilePath import System.IO import System.Directory -import Distribution.Package hiding (depends) +import Distribution.Package hiding (depends, PackageId) -import Control.Exception -import Data.Maybe +import Exception \end{code} @@ -260,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 @@ -286,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 @@ -303,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) @@ -410,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) @@ -453,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 = 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} @@ -497,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 @@ -523,7 +523,7 @@ linkExpr hsc_env span root_ul_bco -- by default, so we can safely ignore them here. dieWith :: SrcSpan -> Message -> IO a -dieWith span msg = throwDyn (ProgramError (showSDoc (mkLocMessage span msg))) +dieWith span msg = ghcError (ProgramError (showSDoc (mkLocMessage span msg))) checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe String) @@ -620,7 +620,7 @@ getLinkDeps hsc_env hpt _ 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"))) @@ -635,8 +635,7 @@ getLinkDeps hsc_env hpt _ 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... @@ -743,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 @@ -996,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 () @@ -1046,13 +1045,13 @@ 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 () @@ -1066,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. @@ -1082,7 +1081,7 @@ locateOneObj dirs lib Nothing -> do { mb_lib_path <- findFile mk_dyn_lib_path dirs ; case mb_lib_path of - Just _ -> return (DLL (lib ++ "-ghc" ++ cProjectVersion)) + Just _ -> return (DLL dyn_lib_name) Nothing -> return (DLL lib) }} -- We assume | otherwise -- When the GHC package was compiled as dynamic library (=__PIC__ set), @@ -1097,7 +1096,8 @@ 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) @@ -1127,7 +1127,7 @@ mkSOName root -- 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"]