X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fghci%2FLinker.lhs;h=21a206490e66ebdb8ab6b1090d6e525f118e9329;hp=0ced78eefbe57890e3dbcbc6957efe5bf322bbbc;hb=703ca1542c8e0983cc9d8eebce6e9f3dd3fd71e2;hpb=251fc4cd2669ab3c8621c0ad3419669e090618d1 diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 0ced78e..21a2064 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -50,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 @@ -75,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} @@ -263,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 @@ -289,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 @@ -306,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) @@ -413,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) @@ -456,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} @@ -500,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 +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) @@ -623,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"))) @@ -638,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... @@ -746,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 @@ -999,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 () @@ -1049,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 () @@ -1069,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. @@ -1131,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"]