diff options
30 files changed, 125 insertions, 117 deletions
diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 0c0b01a3da..8448409707 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -1141,12 +1141,12 @@ realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPri lazyIdName = mkWiredInIdName gHC_BASE (fsLit "lazy") lazyIdKey lazyId errorName = mkWiredInIdName gHC_ERR (fsLit "error") errorIdKey eRROR_ID -recSelErrorName = mkWiredInIdName gHC_ERR (fsLit "recSelError") recSelErrorIdKey rEC_SEL_ERROR_ID -runtimeErrorName = mkWiredInIdName gHC_ERR (fsLit "runtimeError") runtimeErrorIdKey rUNTIME_ERROR_ID -irrefutPatErrorName = mkWiredInIdName gHC_ERR (fsLit "irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID -recConErrorName = mkWiredInIdName gHC_ERR (fsLit "recConError") recConErrorIdKey rEC_CON_ERROR_ID -patErrorName = mkWiredInIdName gHC_ERR (fsLit "patError") patErrorIdKey pAT_ERROR_ID -noMethodBindingErrorName = mkWiredInIdName gHC_ERR (fsLit "noMethodBindingError") +recSelErrorName = mkWiredInIdName cONTROL_EXCEPTION (fsLit "recSelError") recSelErrorIdKey rEC_SEL_ERROR_ID +runtimeErrorName = mkWiredInIdName cONTROL_EXCEPTION (fsLit "runtimeError") runtimeErrorIdKey rUNTIME_ERROR_ID +irrefutPatErrorName = mkWiredInIdName cONTROL_EXCEPTION (fsLit "irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID +recConErrorName = mkWiredInIdName cONTROL_EXCEPTION (fsLit "recConError") recConErrorIdKey rEC_CON_ERROR_ID +patErrorName = mkWiredInIdName cONTROL_EXCEPTION (fsLit "patError") patErrorIdKey pAT_ERROR_ID +noMethodBindingErrorName = mkWiredInIdName cONTROL_EXCEPTION (fsLit "noMethodBindingError") noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID nonExhaustiveGuardsErrorName = mkWiredInIdName gHC_ERR (fsLit "nonExhaustiveGuardsError") diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index 14b5ba4c0e..b45a64318e 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -49,7 +49,6 @@ import Constants import Data.List import Foreign import Foreign.C -import Control.Exception ( throwDyn ) import GHC.Exts ( Int(..), ByteArray# ) @@ -1401,7 +1400,7 @@ idSizeW id = cgRepSizeW (typeCgRep (idType id)) -- See bug #1257 unboxedTupleException :: a unboxedTupleException - = throwDyn + = ghcError (ProgramError ("Error: bytecode compiler can't handle unboxed tuples.\n"++ " Possibly due to foreign import/export decls in source.\n"++ diff --git a/compiler/ghci/ByteCodeLink.lhs b/compiler/ghci/ByteCodeLink.lhs index 63dd7a41bf..54dff1d498 100644 --- a/compiler/ghci/ByteCodeLink.lhs +++ b/compiler/ghci/ByteCodeLink.lhs @@ -42,7 +42,6 @@ import GHC.Word ( Word(..) ) import Data.Array.Base import GHC.Arr ( STArray(..) ) -import Control.Exception ( throwDyn ) import Control.Monad ( zipWithM ) import Control.Monad.ST ( stToIO ) @@ -245,7 +244,7 @@ lookupIE ie con_nm linkFail :: String -> String -> IO a linkFail who what - = throwDyn (ProgramError $ + = ghcError (ProgramError $ unlines [ "" , "During interactive linking, GHCi couldn't find the following symbol:" , ' ' : ' ' : what diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index c0ac9d3166..e10b414610 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -31,7 +31,7 @@ import Outputable import SrcLoc import PprTyThing -import Control.Exception +import Exception import Control.Monad import Data.List import Data.Maybe diff --git a/compiler/ghci/GhciMonad.hs b/compiler/ghci/GhciMonad.hs index 66d1d2ef6f..387d17eb16 100644 --- a/compiler/ghci/GhciMonad.hs +++ b/compiler/ghci/GhciMonad.hs @@ -28,7 +28,7 @@ import StaticFlags import Data.Maybe import Numeric -import Control.Exception as Exception +import Exception import Data.Array import Data.Char import Data.Int ( Int64 ) diff --git a/compiler/ghci/GhciTags.hs b/compiler/ghci/GhciTags.hs index 9959991fab..95d0d61547 100644 --- a/compiler/ghci/GhciTags.hs +++ b/compiler/ghci/GhciTags.hs @@ -19,7 +19,7 @@ import Name (nameOccName) import OccName (pprOccName) import Data.Maybe -import Control.Exception +import Panic import Data.List import Control.Monad import System.IO @@ -59,7 +59,7 @@ createTagsFile session tagskind tagFile = do is_interpreted <- GHC.moduleIsInterpreted session m -- should we just skip these? when (not is_interpreted) $ - throwDyn (CmdLineError ("module '" + ghcError (CmdLineError ("module '" ++ GHC.moduleNameString (GHC.moduleName m) ++ "' is not interpreted")) mbModInfo <- GHC.getModuleInfo session m @@ -113,7 +113,7 @@ collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs tagGroups <- mapM tagFileGroup groups IO.try (writeFile file $ concat tagGroups) where - tagFileGroup [] = throwDyn (CmdLineError "empty tag file group??") + tagFileGroup [] = ghcError (CmdLineError "empty tag file group??") tagFileGroup group@((_,fileName,_,_):_) = do file <- readFile fileName -- need to get additional info from sources.. let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2 diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 9e72a38721..7adb0642dc 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -68,7 +68,7 @@ import System.Console.Editline.Readline as Readline --import SystemExts -import Control.Exception as Exception +import Exception -- import Control.Concurrent import System.FilePath @@ -857,7 +857,7 @@ help :: String -> GHCi () help _ = io (putStr helpText) info :: String -> GHCi () -info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'") +info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'") info s = do { let names = words s ; session <- getSession ; dflags <- getDynFlags @@ -947,7 +947,7 @@ editFile str = st <- getGHCiState let cmd = editor st when (null cmd) - $ throwDyn (CmdLineError "editor not set, use :set editor") + $ ghcError (CmdLineError "editor not set, use :set editor") io $ system (cmd ++ ' ':file) return () @@ -979,7 +979,7 @@ chooseEditFile = do targets <- io (GHC.getTargets session) case msum (map fromTarget targets) of Just file -> return file - Nothing -> throwDyn (CmdLineError "No files to edit.") + Nothing -> ghcError (CmdLineError "No files to edit.") where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f fromTarget _ = Nothing -- when would we get a module target? @@ -996,7 +996,7 @@ defineMacro overwrite s = do unlines defined) else do if (not overwrite && macro_name `elem` defined) - then throwDyn (CmdLineError + then ghcError (CmdLineError ("macro '" ++ macro_name ++ "' is already defined")) else do @@ -1025,7 +1025,7 @@ undefineMacro str = mapM_ undef (words str) where undef macro_name = do cmds <- io (readIORef macros_ref) if (macro_name `notElem` map cmdName cmds) - then throwDyn (CmdLineError + then ghcError (CmdLineError ("macro '" ++ macro_name ++ "' is not defined")) else do io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds)) @@ -1239,8 +1239,8 @@ browseCmd bang m = case (as,bs) of (as@(_:_), _) -> browseModule bang (last as) True ([], bs@(_:_)) -> browseModule bang (last bs) True - ([], []) -> throwDyn (CmdLineError ":browse: no current module") - _ -> throwDyn (CmdLineError "syntax: :browse <module>") + ([], []) -> ghcError (CmdLineError ":browse: no current module") + _ -> ghcError (CmdLineError "syntax: :browse <module>") -- without bang, show items in context of their parents and omit children -- with bang, show class methods and data constructors separately, and @@ -1264,7 +1264,7 @@ browseModule bang modl exports_only = do mb_mod_info <- io $ GHC.getModuleInfo s modl case mb_mod_info of - Nothing -> throwDyn (CmdLineError ("unknown module: " ++ + Nothing -> ghcError (CmdLineError ("unknown module: " ++ GHC.moduleNameString (GHC.moduleName modl))) Just mod_info -> do dflags <- getDynFlags @@ -1336,7 +1336,7 @@ setContext str playCtxtCmd True (cmd, as, bs) st <- getGHCiState setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] } - | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn") + | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn") where (cmd, strs, as, bs) = case str of @@ -1507,7 +1507,7 @@ newDynFlags minus_opts = do io $ handleFlagWarnings dflags' warns if (not (null leftovers)) - then throwDyn (CmdLineError ("unrecognised flags: " ++ + then ghcError (CmdLineError ("unrecognised flags: " ++ unwords leftovers)) else return () @@ -1541,7 +1541,7 @@ unsetOptions str mapM_ unsetOpt plus_opts let no_flag ('-':'f':rest) = return ("-fno-" ++ rest) - no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f)) + no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f)) no_flags <- mapM no_flag minus_opts newDynFlags no_flags @@ -1596,7 +1596,7 @@ showCmd str = do ["context"] -> showContext ["packages"] -> showPackages ["languages"] -> showLanguages - _ -> throwDyn (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++ + _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++ " | breaks | context | packages | languages ]")) showModules :: GHCi () @@ -1880,7 +1880,7 @@ wantInterpretedModule str = do modl <- lookupModule str is_interpreted <- io (GHC.moduleIsInterpreted session modl) when (not is_interpreted) $ - throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted")) + ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted")) return modl wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String @@ -2094,7 +2094,7 @@ breakByModuleLine mod line args | otherwise = breakSyntax breakSyntax :: a -breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]") +breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]") findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi () findBreakAndSet mod lookupTickTree = do diff --git a/compiler/ghci/LibFFI.hsc b/compiler/ghci/LibFFI.hsc index 7f24d01a7d..e73b023958 100644 --- a/compiler/ghci/LibFFI.hsc +++ b/compiler/ghci/LibFFI.hsc @@ -22,7 +22,6 @@ import Constants import Foreign import Foreign.C import Text.Printf -import Control.Exception ---------------------------------------------------------------------------- @@ -45,7 +44,7 @@ prepForeignCall cconv arg_types result_type let res_ty = primRepToFFIType result_type r <- ffi_prep_cif cif abi (fromIntegral n_args) res_ty arg_arr if (r /= fFI_OK) - then throwDyn (InstallationError + then ghcError (InstallationError (printf "prepForeignCallFailed: %d" (show r))) else return cif diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 0ced78eefb..f41a7bab03 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -77,7 +77,7 @@ import System.Directory import Distribution.Package hiding (depends) -import Control.Exception +import Exception import Data.Maybe \end{code} @@ -263,7 +263,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 @@ -413,7 +413,7 @@ reallyInitDynLinker dflags ; ok <- resolveObjs ; if succeeded ok then maybePutStrLn dflags "done" - else throwDyn (InstallationError "linking extra libraries/objects failed") + else ghcError (InstallationError "linking extra libraries/objects failed") }} classifyLdInput :: FilePath -> IO (Maybe LibrarySpec) @@ -469,7 +469,7 @@ preloadLib dflags lib_paths framework_paths lib_spec if not b then return False else loadObj name >> return True - give_up = throwDyn $ + give_up = ghcError $ CmdLineError "user specified .o/.so/.DLL could not be loaded." \end{code} @@ -500,7 +500,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 +526,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 +623,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"))) @@ -999,7 +999,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 +1049,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 +1069,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 +1131,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 <- Exception.try getHomeDirectory ; let homeFrameworkPath = case either_dir of Left _ -> [] Right dir -> [dir ++ "/Library/Frameworks"] diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index a544b625e9..c155fb28c4 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -44,7 +44,6 @@ import Data.List import Data.Word import Data.Array import Data.IORef -import Control.Exception import Control.Monad data CheckHiWay = CheckHiWay | IgnoreHiWay @@ -82,7 +81,7 @@ readBinIface_ checkHiWay traceBinIFaceReading hi_path nc = do errorOnMismatch what wanted got -- This will be caught by readIface which will emit an error -- msg containing the iface module name. - = when (wanted /= got) $ throwDyn $ ProgramError + = when (wanted /= got) $ ghcError $ ProgramError (what ++ " (wanted " ++ show wanted ++ ", got " ++ show got ++ ")") bh <- Binary.readBinMem hi_path diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs index 1b3792e788..307e43f314 100644 --- a/compiler/main/DriverMkDepend.hs +++ b/compiler/main/DriverMkDepend.hs @@ -33,7 +33,6 @@ import FastString import ErrUtils ( debugTraceMsg, putMsg ) -import Control.Exception import System.Exit ( ExitCode(..), exitWith ) import System.Directory import System.FilePath @@ -171,7 +170,7 @@ processDeps :: DynFlags processDeps _ _ _ _ (CyclicSCC nodes) = -- There shouldn't be any cycles; report them - throwDyn (ProgramError (showSDoc $ GHC.cyclicModuleErr nodes)) + ghcError (ProgramError (showSDoc $ GHC.cyclicModuleErr nodes)) processDeps dflags session excl_mods hdl (AcyclicSCC node) = do { hsc_env <- GHC.sessionHscEnv session diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 983bebef6f..6721b9154c 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -50,7 +50,7 @@ import SrcLoc ( unLoc ) import SrcLoc ( Located(..) ) import FastString -import Control.Exception as Exception +import Exception import Data.IORef ( readIORef, writeIORef, IORef ) import GHC.Exts ( Int(..) ) import System.Directory @@ -351,7 +351,7 @@ compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath compileFile hsc_env stop_phase (src, mb_phase) = do exists <- doesFileExist src when (not exists) $ - throwDyn (CmdLineError ("does not exist: " ++ src)) + ghcError (CmdLineError ("does not exist: " ++ src)) let dflags = hsc_dflags hsc_env @@ -451,7 +451,7 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_lo -- before B in a normal compilation pipeline. when (not (start_phase `happensBefore` stop_phase)) $ - throwDyn (UsageError + ghcError (UsageError ("cannot compile this file to desired target: " ++ input_fn)) @@ -777,7 +777,7 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma Nothing -- No "module i of n" progress info case mbResult of - Nothing -> throwDyn (PhaseFailed "hsc" (ExitFailure 1)) + Nothing -> ghcError (PhaseFailed "hsc" (ExitFailure 1)) Just HscNoRecomp -> do SysTools.touch dflags' "Touching object file" o_file -- The .o file must have a later modification date @@ -818,7 +818,7 @@ runPhase Cmm stop hsc_env basename _ input_fn get_output_fn maybe_loc ok <- hscCmmFile hsc_env' input_fn - when (not ok) $ throwDyn (PhaseFailed "cmm" (ExitFailure 1)) + when (not ok) $ ghcError (PhaseFailed "cmm" (ExitFailure 1)) return (next_phase, dflags, maybe_loc, output_fn) @@ -1352,7 +1352,7 @@ linkBinary dflags o_files dep_packages = do -- parallel only: move binary to another dir -- HWL success <- runPhase_MoveBinary dflags output_fn dep_packages if success then return () - else throwDyn (InstallationError ("cannot move binary")) + else ghcError (InstallationError ("cannot move binary")) exeFileName :: DynFlags -> FilePath diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 3bb7c1ccd0..c3700bf7f0 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -69,7 +69,7 @@ import DriverPhases ( Phase(..), phaseInputExt ) import Config import CmdLineParser import Constants ( mAX_CONTEXT_REDUCTION_DEPTH ) -import Panic ( panic, GhcException(..) ) +import Panic import UniqFM ( UniqFM ) import Util import Maybes ( orElse ) @@ -78,7 +78,6 @@ import Outputable import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage ) import Data.IORef ( readIORef ) -import Control.Exception ( throwDyn ) import Control.Monad ( when ) import Data.Char @@ -1668,7 +1667,7 @@ parseDynamicFlags dflags args = do let ((leftover, errs, warns), dflags') = runCmdLine (processArgs dynamic_flags args') dflags when (not (null errs)) $ do - throwDyn (UsageError (unlines errs)) + ghcError (UsageError (unlines errs)) return (dflags', leftover, warns) type DynP = CmdLineP DynFlags @@ -1760,7 +1759,7 @@ ignorePackage p = setPackageName :: String -> DynFlags -> DynFlags setPackageName p | Nothing <- unpackPackageId pid - = throwDyn (CmdLineError ("cannot parse \'" ++ p ++ "\' as a package identifier")) + = ghcError (CmdLineError ("cannot parse \'" ++ p ++ "\' as a package identifier")) | otherwise = \s -> s{ thisPackage = pid } where diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 26f13d105e..50261d8621 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -274,7 +274,7 @@ import qualified Data.List as List import Control.Monad import System.Exit ( exitWith, ExitCode(..) ) import System.Time ( ClockTime, getClockTime ) -import Control.Exception as Exception hiding (handle) +import Exception hiding (handle) import Data.IORef import System.FilePath import System.IO @@ -1554,7 +1554,7 @@ topSortModuleGraph drop_hs_boot_nodes summaries (Just mod) (graph, vertex_fn, key_fn) = graphFromEdges' nodes root | Just key <- lookup_key HsSrcFile mod, Just v <- key_fn key = v - | otherwise = throwDyn (ProgramError "module does not exist") + | otherwise = ghcError (ProgramError "module does not exist") moduleGraphNodes :: Bool -> [ModSummary] -> ([(ModSummary, Int, [Int])], HscSource -> ModuleName -> Maybe Int) @@ -2246,11 +2246,11 @@ findModule s mod_name maybe_pkg = withSession s $ \hsc_env -> res <- findImportedModule hsc_env mod_name maybe_pkg case res of Found _ m | modulePackageId m /= this_pkg -> return m - | otherwise -> throwDyn (CmdLineError (showSDoc $ + | otherwise -> ghcError (CmdLineError (showSDoc $ text "module" <+> quotes (ppr (moduleName m)) <+> text "is not loaded")) err -> let msg = cannotFindModule dflags mod_name err in - throwDyn (CmdLineError (showSDoc msg)) + ghcError (CmdLineError (showSDoc msg)) #ifdef GHCI getHistorySpan :: Session -> History -> IO SrcSpan diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index 26c854b3a7..dc061ba553 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -40,7 +40,7 @@ import Panic import Maybes import Bag ( emptyBag, listToBag ) -import Control.Exception +import Exception import Control.Monad import System.Exit import System.IO @@ -87,7 +87,7 @@ getOptionsFromFile :: DynFlags -> FilePath -- input file -> IO [Located String] -- options, if any getOptionsFromFile dflags filename - = Control.Exception.bracket + = Exception.bracket (openBinaryFile filename ReadMode) (hClose) (\handle -> @@ -181,7 +181,7 @@ getOptions' dflags buf filename checkProcessArgsResult :: [String] -> FilePath -> IO () checkProcessArgsResult flags filename - = do when (notNull flags) (throwDyn (ProgramError ( + = do when (notNull flags) (ghcError (ProgramError ( showSDoc (hang (text filename <> char ':') 4 (text "unknown flags in {-# OPTIONS #-} pragma:" <+> hsep (map text flags))) diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 44846ffdbb..f15c5f4238 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -78,7 +78,7 @@ import Foreign import Foreign.C import GHC.Exts import Data.Array -import Control.Exception as Exception +import Exception import Control.Concurrent import Data.List (sortBy) import Data.IORef @@ -407,7 +407,7 @@ resume (Session ref) step resume = ic_resume ic case resume of - [] -> throwDyn (ProgramError "not stopped at a breakpoint") + [] -> ghcError (ProgramError "not stopped at a breakpoint") (r:rs) -> do -- unbind the temporary locals by restoring the TypeEnv from -- before the breakpoint, and drop this Resume from the @@ -458,16 +458,16 @@ moveHist :: (Int -> Int) -> Session -> IO ([Name], Int, SrcSpan) moveHist fn (Session ref) = do hsc_env <- readIORef ref case ic_resume (hsc_IC hsc_env) of - [] -> throwDyn (ProgramError "not stopped at a breakpoint") + [] -> ghcError (ProgramError "not stopped at a breakpoint") (r:rs) -> do let ix = resumeHistoryIx r history = resumeHistory r new_ix = fn ix -- when (new_ix > length history) $ - throwDyn (ProgramError "no more logged breakpoints") + ghcError (ProgramError "no more logged breakpoints") when (new_ix < 0) $ - throwDyn (ProgramError "already at the beginning of the history") + ghcError (ProgramError "already at the beginning of the history") let update_ic apStack mb_info = do @@ -775,12 +775,12 @@ vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}] mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv mkTopLevEnv hpt modl = case lookupUFM hpt (moduleName modl) of - Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++ + Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++ showSDoc (ppr modl))) Just details -> case mi_globals (hm_iface details) of Nothing -> - throwDyn (ProgramError ("mkTopLevEnv: not interpreted " + ghcError (ProgramError ("mkTopLevEnv: not interpreted " ++ showSDoc (ppr modl))) Just env -> return env diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index b6c320fcad..1bafe6cf66 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -61,7 +61,6 @@ import System.FilePath import Data.Maybe import Control.Monad import Data.List -import Control.Exception ( throwDyn ) -- --------------------------------------------------------------------------- -- The Package state @@ -687,7 +686,7 @@ closeDeps pkg_map ps = throwErr (closeDepsErr pkg_map ps) throwErr :: MaybeErr Message a -> IO a throwErr m = case m of - Failed e -> throwDyn (CmdLineError (showSDoc e)) + Failed e -> ghcError (CmdLineError (showSDoc e)) Succeeded r -> return r closeDepsErr :: PackageConfigMap -> [(PackageId,Maybe PackageId)] @@ -710,7 +709,7 @@ add_package pkg_db ps (p, mb_parent) return (p : ps') missingPackageErr :: String -> IO [PackageConfig] -missingPackageErr p = throwDyn (CmdLineError (showSDoc (missingPackageMsg p))) +missingPackageErr p = ghcError (CmdLineError (showSDoc (missingPackageMsg p))) missingPackageMsg :: String -> SDoc missingPackageMsg p = ptext (sLit "unknown package:") <+> text p diff --git a/compiler/main/ParsePkgConf.y b/compiler/main/ParsePkgConf.y index b09f2b39a7..9cf6d0491a 100644 --- a/compiler/main/ParsePkgConf.y +++ b/compiler/main/ParsePkgConf.y @@ -20,8 +20,7 @@ import StringBuffer import ErrUtils ( mkLocMessage ) import SrcLoc import Outputable -import Panic ( GhcException(..) ) -import Control.Exception ( throwDyn ) +import Panic } @@ -162,7 +161,7 @@ loadPackageConfig dflags conf_filename = do let loc = mkSrcLoc (mkFastString conf_filename) 1 0 case unP parse (mkPState buf loc dflags) of PFailed span err -> - throwDyn (InstallationError (showSDoc (mkLocMessage span err))) + ghcError (InstallationError (showSDoc (mkLocMessage span err))) POk _ pkg_details -> do return pkg_details diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index 499367dafd..c159799742 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -86,7 +86,6 @@ import Util import Maybes ( firstJust ) import Panic -import Control.Exception ( throwDyn ) import Data.IORef import System.IO.Unsafe ( unsafePerformIO ) import Control.Monad ( when ) @@ -99,10 +98,10 @@ import Data.List parseStaticFlags :: [String] -> IO ([String], [String]) parseStaticFlags args = do ready <- readIORef v_opt_C_ready - when ready $ throwDyn (ProgramError "Too late for parseStaticFlags: call it before newSession") + when ready $ ghcError (ProgramError "Too late for parseStaticFlags: call it before newSession") (leftover, errs, warns1) <- processArgs static_flags args - when (not (null errs)) $ throwDyn (UsageError (unlines errs)) + when (not (null errs)) $ ghcError (UsageError (unlines errs)) -- deal with the way flags: the way (eg. prof) gives rise to -- further flags, some of which might be static. @@ -463,7 +462,7 @@ decodeSize str | c == "K" || c == "k" = truncate (n * 1000) | c == "M" || c == "m" = truncate (n * 1000 * 1000) | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000) - | otherwise = throwDyn (CmdLineError ("can't decode size: " ++ str)) + | otherwise = ghcError (CmdLineError ("can't decode size: " ++ str)) where (m, c) = span pred str n = readRational m pred c = isDigit c || c == '.' @@ -549,7 +548,7 @@ findBuildTag = do let ws = sort (nub way_names) if not (allowed_combination ws) - then throwDyn (CmdLineError $ + then ghcError (CmdLineError $ "combination not supported: " ++ foldr1 (\a b -> a ++ '/':b) (map (wayName . lkupWay) ws)) diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 6d377743c8..3c465edd73 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -48,7 +48,7 @@ import Util import DynFlags import FiniteMap -import Control.Exception +import Exception import Data.IORef import Control.Monad import System.Exit @@ -209,7 +209,7 @@ initSysTools mbMinusB dflags0 -- Check that the package config exists ; config_exists <- doesFileExist pkgconfig_path ; when (not config_exists) $ - throwDyn (InstallationError + ghcError (InstallationError ("Can't find package.conf as " ++ pkgconfig_path)) -- On Windows, gcc and friends are distributed with GHC, @@ -330,7 +330,7 @@ findTopDir mbMinusB -> do maybe_exec_dir <- getBaseDir -- Get directory of executable case maybe_exec_dir of -- (only works on Windows; -- returns Nothing on Unix) - Nothing -> throwDyn (InstallationError "missing -B<dir> option") + Nothing -> ghcError (InstallationError "missing -B<dir> option") Just dir -> return dir \end{code} @@ -677,9 +677,9 @@ runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do then return (ExitFailure 1, True) else IO.ioError err) case (doesn'tExist, exit_code) of - (True, _) -> throwDyn (InstallationError ("could not execute: " ++ pgm)) + (True, _) -> ghcError (InstallationError ("could not execute: " ++ pgm)) (_, ExitSuccess) -> return () - _ -> throwDyn (PhaseFailed phase_name exit_code) + _ -> ghcError (PhaseFailed phase_name exit_code) builderMainLoop :: DynFlags -> (String -> String) -> FilePath -> [String] -> Maybe [(String, String)] @@ -817,7 +817,7 @@ traceCmd dflags phase_name cmd_line action where handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n') ; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn)) - ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) } + ; ghcError (PhaseFailed phase_name (ExitFailure 1)) } \end{code} %************************************************************************ diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 193c1eb83f..8cc2424826 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -237,7 +237,7 @@ gHC_PRIM, gHC_BOOL, gHC_UNIT, gHC_ORDERING, gHC_GENERICS, gHC_BASE, gHC_ENUM, gHC_ST, gHC_ARR, gHC_STABLE, gHC_ADDR, gHC_PTR, gHC_ERR, gHC_REAL, gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, tYPEABLE, gENERICS, dOTNET, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, aRROW, - gHC_DESUGAR, rANDOM, gHC_EXTS :: Module + gHC_DESUGAR, rANDOM, gHC_EXTS, cONTROL_EXCEPTION :: Module gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values gHC_UNIT = mkPrimModule (fsLit "GHC.Unit") gHC_BOOL = mkPrimModule (fsLit "GHC.Bool") @@ -281,6 +281,7 @@ aRROW = mkBaseModule (fsLit "Control.Arrow") gHC_DESUGAR = mkBaseModule (fsLit "GHC.Desugar") rANDOM = mkBaseModule (fsLit "System.Random") gHC_EXTS = mkBaseModule (fsLit "GHC.Exts") +cONTROL_EXCEPTION = mkBaseModule (fsLit "Control.Exception") mAIN, rOOT_MAIN :: Module mAIN = mkMainModule_ mAIN_NAME diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index abdb44e642..d1f2968d5e 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -43,7 +43,6 @@ import Util import System.IO import Data.IORef -import Control.Exception import Control.Monad \end{code} diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 60d6a6b8e2..f65dc29ad7 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -69,7 +69,7 @@ import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Syntax as TH import GHC.Exts ( unsafeCoerce#, Int#, Int(..) ) -import qualified Control.Exception as Exception( userErrors ) +import qualified Exception ( userErrors ) \end{code} Note [Template Haskell levels] diff --git a/compiler/utils/Exception.hs b/compiler/utils/Exception.hs new file mode 100644 index 0000000000..11172b59b1 --- /dev/null +++ b/compiler/utils/Exception.hs @@ -0,0 +1,19 @@ + +module Exception + ( +#if __GLASGOW_HASKELL__ >= 609 + module Control.OldException +#else + module Control.Exception +#endif + ) + where + +import Prelude () + +#if __GLASGOW_HASKELL__ >= 609 +import Control.OldException +#else +import Control.Exception +#endif + diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs index 97648b72de..71c484e59d 100644 --- a/compiler/utils/Panic.lhs +++ b/compiler/utils/Panic.lhs @@ -35,10 +35,9 @@ import System.Posix.Signals import GHC.ConsoleHandler #endif -import Control.Exception +import Exception import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar ) import Data.Dynamic -import qualified Control.Exception as Exception import Debug.Trace ( trace ) import System.IO.Unsafe ( unsafePerformIO ) import System.IO.Error ( isUserError ) diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index 7057d321a1..fcb8bd9508 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -79,8 +79,8 @@ module Util ( import Panic -import Control.Exception ( Exception(..), finally, catchDyn, throw ) -import qualified Control.Exception as Exception +import Exception ( Exception(..), finally, catchDyn, throw ) +import qualified Exception import Data.Dynamic ( Typeable ) import Data.IORef ( IORef, newIORef ) import System.IO.Unsafe ( unsafePerformIO ) diff --git a/ghc/Main.hs b/ghc/Main.hs index a91df13575..a2c2fd1a52 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -44,7 +44,6 @@ import Util import Panic -- Standard Haskell libraries -import Control.Exception ( throwDyn ) import System.IO import System.Environment import System.Exit @@ -188,7 +187,7 @@ main = #ifndef GHCI interactiveUI :: a -> b -> c -> IO () interactiveUI _ _ _ = - throwDyn (CmdLineError "not built for interactive use") + ghcError (CmdLineError "not built for interactive use") #endif -- ----------------------------------------------------------------------------- @@ -249,24 +248,24 @@ checkOptions cli_mode dflags srcs objs = do -- -prof and --interactive are not a good combination when (notNull (filter (not . isRTSWay) (wayNames dflags)) && isInterpretiveMode cli_mode) $ - do throwDyn (UsageError + do ghcError (UsageError "--interactive can't be used with -prof or -unreg.") -- -ohi sanity check if (isJust (outputHi dflags) && (isCompManagerMode cli_mode || srcs `lengthExceeds` 1)) - then throwDyn (UsageError "-ohi can only be used when compiling a single source file") + then ghcError (UsageError "-ohi can only be used when compiling a single source file") else do -- -o sanity checking if (srcs `lengthExceeds` 1 && isJust (outputFile dflags) && not (isLinkMode cli_mode)) - then throwDyn (UsageError "can't apply -o to multiple source files") + then ghcError (UsageError "can't apply -o to multiple source files") else do -- Check that there are some input files -- (except in the interactive case) if null srcs && null objs && needsInputsMode cli_mode - then throwDyn (UsageError "no input files") + then ghcError (UsageError "no input files") else do -- Verify that output files point somewhere sensible. @@ -297,7 +296,7 @@ verifyOutputFiles dflags = do when (not flg) (nonExistentDir "-ohi" hi) where nonExistentDir flg dir = - throwDyn (CmdLineError ("error: directory portion of " ++ + ghcError (CmdLineError ("error: directory portion of " ++ show dir ++ " does not exist (used with " ++ show flg ++ " option.)")) @@ -360,7 +359,7 @@ parseModeFlags args = do let ((leftover, errs, warns), (mode, _, flags')) = runCmdLine (processArgs mode_flags args) (StopBefore StopLn, "", []) when (not (null errs)) $ do - throwDyn (UsageError (unlines errs)) + ghcError (UsageError (unlines errs)) return (mode, flags' ++ leftover, warns) type ModeM = CmdLineP (CmdLineMode, String, [String]) @@ -427,7 +426,7 @@ updateMode :: (CmdLineMode -> CmdLineMode) -> String -> ModeM () updateMode f flag = do (old_mode, old_flag, flags') <- getCmdLineState if notNull old_flag && flag /= old_flag - then throwDyn (UsageError + then ghcError (UsageError ("cannot use `" ++ old_flag ++ "' with `" ++ flag ++ "'")) else putCmdLineState (f old_mode, flag, flags') @@ -441,7 +440,7 @@ addFlag s = do -- Run --make mode doMake :: Session -> [(String,Maybe Phase)] -> IO () -doMake _ [] = throwDyn (UsageError "no input files") +doMake _ [] = ghcError (UsageError "no input files") doMake sess srcs = do let (hs_srcs, non_hs_srcs) = partition haskellish srcs @@ -560,4 +559,4 @@ countFS entries longest is_z has_z (b:bs) = -- Util unknownFlagsErr :: [String] -> a -unknownFlagsErr fs = throwDyn (UsageError ("unrecognised flags: " ++ unwords fs)) +unknownFlagsErr fs = ghcError (UsageError ("unrecognised flags: " ++ unwords fs)) diff --git a/rts/Prelude.h b/rts/Prelude.h index 2acd02dfd1..f483650e7c 100644 --- a/rts/Prelude.h +++ b/rts/Prelude.h @@ -39,8 +39,8 @@ PRELUDE_CLOSURE(base_GHCziIOBase_stackOverflow_closure); PRELUDE_CLOSURE(base_GHCziIOBase_heapOverflow_closure); PRELUDE_CLOSURE(base_GHCziIOBase_BlockedOnDeadMVar_closure); PRELUDE_CLOSURE(base_GHCziIOBase_BlockedIndefinitely_closure); -PRELUDE_CLOSURE(base_GHCziIOBase_nonTermination_closure); -PRELUDE_CLOSURE(base_GHCziIOBase_NestedAtomically_closure); +PRELUDE_CLOSURE(base_ControlziException_nonTermination_closure); +PRELUDE_CLOSURE(base_ControlziException_nestedAtomically_closure); PRELUDE_CLOSURE(base_GHCziConc_ensureIOManagerIsRunning_closure); @@ -89,8 +89,8 @@ PRELUDE_INFO(base_GHCziStable_StablePtr_con_info); #define heapOverflow_closure DLL_IMPORT_DATA_REF(base_GHCziIOBase_heapOverflow_closure) #define BlockedOnDeadMVar_closure DLL_IMPORT_DATA_REF(base_GHCziIOBase_BlockedOnDeadMVar_closure) #define BlockedIndefinitely_closure DLL_IMPORT_DATA_REF(base_GHCziIOBase_BlockedIndefinitely_closure) -#define nonTermination_closure DLL_IMPORT_DATA_REF(base_GHCziIOBase_nonTermination_closure) -#define NestedAtomically_closure DLL_IMPORT_DATA_REF(base_GHCziIOBase_NestedAtomically_closure) +#define nonTermination_closure DLL_IMPORT_DATA_REF(base_ControlziException_nonTermination_closure) +#define NestedAtomically_closure DLL_IMPORT_DATA_REF(base_ControlziException_nestedAtomically_closure) #define Czh_static_info DLL_IMPORT_DATA_REF(base_GHCziBase_Czh_static_info) #define Fzh_static_info DLL_IMPORT_DATA_REF(base_GHCziFloat_Fzh_static_info) diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index 99d71abbf2..b8d8ccc5a9 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -49,7 +49,7 @@ import __gmpz_com; import pthread_mutex_lock; import pthread_mutex_unlock; #endif -import base_GHCziIOBase_NestedAtomically_closure; +import base_ControlziException_nestedAtomically_closure; import EnterCriticalSection; import LeaveCriticalSection; @@ -1251,7 +1251,7 @@ atomicallyzh_fast /* Nested transactions are not allowed; raise an exception */ if (old_trec != NO_TREC) { - R1 = base_GHCziIOBase_NestedAtomically_closure; + R1 = base_ControlziException_nestedAtomically_closure; jump raisezh_fast; } diff --git a/rts/package.conf.in b/rts/package.conf.in index 045ec1f923..4dd824e35d 100644 --- a/rts/package.conf.in +++ b/rts/package.conf.in @@ -105,11 +105,11 @@ ld-options: , "-u", "_base_GHCziPack_unpackCString_closure" , "-u", "_base_GHCziIOBase_stackOverflow_closure" , "-u", "_base_GHCziIOBase_heapOverflow_closure" - , "-u", "_base_GHCziIOBase_nonTermination_closure" + , "-u", "_base_ControlziException_nonTermination_closure" , "-u", "_base_GHCziIOBase_BlockedOnDeadMVar_closure" , "-u", "_base_GHCziIOBase_BlockedIndefinitely_closure" , "-u", "_base_GHCziIOBase_Deadlock_closure" - , "-u", "_base_GHCziIOBase_NestedAtomically_closure" + , "-u", "_base_ControlziException_nestedAtomically_closure" , "-u", "_base_GHCziWeak_runFinalizzerBatch_closure" #else "-u", "base_GHCziBase_Izh_static_info" @@ -139,11 +139,11 @@ ld-options: , "-u", "base_GHCziPack_unpackCString_closure" , "-u", "base_GHCziIOBase_stackOverflow_closure" , "-u", "base_GHCziIOBase_heapOverflow_closure" - , "-u", "base_GHCziIOBase_nonTermination_closure" + , "-u", "base_ControlziException_nonTermination_closure" , "-u", "base_GHCziIOBase_BlockedOnDeadMVar_closure" , "-u", "base_GHCziIOBase_BlockedIndefinitely_closure" , "-u", "base_GHCziIOBase_Deadlock_closure" - , "-u", "base_GHCziIOBase_NestedAtomically_closure" + , "-u", "base_ControlziException_nestedAtomically_closure" , "-u", "base_GHCziWeak_runFinalizzerBatch_closure" #endif |