X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=531440765f5e979b088123eccdb61178da438538;hb=fec15030261949611ae41ab4a356a511db1bac4a;hp=bf3bfd1eb4cafb9a4baedeaafcf0c08cf482024f;hpb=06c159151e9cdecbe0602700a88147d2d1e4e225;p=ghc-hetmet.git diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index bf3bfd1..5314407 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -223,7 +223,7 @@ import HsSyn hiding ((<.>)) import Type hiding (typeKind) import TcType hiding (typeKind) import Id -import Var hiding (setIdType) +import Var import TysPrim ( alphaTyVars ) import TyCon import Class @@ -239,7 +239,7 @@ import CoreSyn import TidyPgm import DriverPipeline import DriverPhases ( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase ) -import HeaderInfo ( getImports, getOptions ) +import HeaderInfo import Finder import HscMain import HscTypes @@ -255,10 +255,7 @@ import FiniteMap import Panic import Digraph import Bag ( unitBag, listToBag ) -import ErrUtils ( Severity(..), showPass, fatalErrorMsg, debugTraceMsg, - mkPlainErrMsg, printBagOfErrors, printBagOfWarnings, - WarnMsg ) -import qualified ErrUtils +import ErrUtils import Util import StringBuffer ( StringBuffer, hGetStringBuffer ) import Outputable @@ -277,11 +274,14 @@ 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 import Data.IORef import System.FilePath import System.IO import System.IO.Error ( try, isDoesNotExistError ) +#if __GLASGOW_HASKELL__ >= 609 +import Data.Typeable (cast) +#endif import Prelude hiding (init) @@ -293,33 +293,55 @@ import Prelude hiding (init) -- the top level of your program. The default handlers output the error -- message(s) to stderr and exit cleanly. defaultErrorHandler :: DynFlags -> IO a -> IO a -defaultErrorHandler dflags inner = +defaultErrorHandler dflags inner = -- top-level exception handler: any unrecognised exception is a compiler bug. +#if __GLASGOW_HASKELL__ < 609 handle (\exception -> do - hFlush stdout - case exception of - -- an IO exception probably isn't our fault, so don't panic - IOException _ -> - fatalErrorMsg dflags (text (show exception)) - AsyncException StackOverflow -> - fatalErrorMsg dflags (text "stack overflow: use +RTS -K to increase it") - _other -> - fatalErrorMsg dflags (text (show (Panic (show exception)))) - exitWith (ExitFailure 1) + hFlush stdout + case exception of + -- an IO exception probably isn't our fault, so don't panic + IOException _ -> + fatalErrorMsg dflags (text (show exception)) + AsyncException StackOverflow -> + fatalErrorMsg dflags (text "stack overflow: use +RTS -K to increase it") + ExitException _ -> throw exception + _ -> + fatalErrorMsg dflags (text (show (Panic (show exception)))) + exitWith (ExitFailure 1) + ) $ +#else + handle (\(SomeException exception) -> do + hFlush stdout + case cast exception of + -- an IO exception probably isn't our fault, so don't panic + Just (ioe :: IOException) -> + fatalErrorMsg dflags (text (show ioe)) + _ -> case cast exception of + Just StackOverflow -> + fatalErrorMsg dflags (text "stack overflow: use +RTS -K to increase it") + _ -> case cast exception of + Just (ex :: ExitCode) -> throw ex + _ -> + fatalErrorMsg dflags + (text (show (Panic (show exception)))) + exitWith (ExitFailure 1) ) $ +#endif -- program errors: messages with locations attached. Sometimes it is -- convenient to just throw these as exceptions. - handleDyn (\dyn -> do printBagOfErrors dflags (unitBag dyn) - exitWith (ExitFailure 1)) $ + handleErrMsg + (\em -> do printBagOfErrors dflags (unitBag em) + exitWith (ExitFailure 1)) $ -- error messages propagated as exceptions - handleDyn (\dyn -> do + handleGhcException + (\ge -> do hFlush stdout - case dyn of + case ge of PhaseFailed _ code -> exitWith code Interrupted -> exitWith (ExitFailure 1) - _ -> do fatalErrorMsg dflags (text (show (dyn :: GhcException))) + _ -> do fatalErrorMsg dflags (text (show ge)) exitWith (ExitFailure 1) ) $ inner @@ -331,13 +353,13 @@ defaultErrorHandler dflags inner = defaultCleanupHandler :: DynFlags -> IO a -> IO a defaultCleanupHandler dflags inner = -- make sure we clean up after ourselves - later (do cleanTempFiles dflags + inner `onException` + (do cleanTempFiles dflags cleanTempDirs dflags ) -- exceptions will be blocked while we clean the temporary files, -- so there shouldn't be any difficulty if we receive further -- signals. - inner -- | Starts a new session. A session consists of a set of loaded @@ -393,16 +415,25 @@ guessOutputFile :: Session -> IO () guessOutputFile s = modifySession s $ \env -> let dflags = hsc_dflags env mod_graph = hsc_mod_graph env - mainModuleSrcPath, guessedName :: Maybe String + mainModuleSrcPath :: Maybe String mainModuleSrcPath = do let isMain = (== mainModIs dflags) . ms_mod [ms] <- return (filter isMain mod_graph) ml_hs_file (ms_location ms) - guessedName = fmap dropExtension mainModuleSrcPath + name = fmap dropExtension mainModuleSrcPath + +#if defined(mingw32_HOST_OS) + -- we must add the .exe extention unconditionally here, otherwise + -- when name has an extension of its own, the .exe extension will + -- not be added by DriverPipeline.exeFileName. See #2248 + name_exe = fmap (<.> "exe") name +#else + name_exe = name +#endif in case outputFile dflags of Just _ -> env - Nothing -> env { hsc_dflags = dflags { outputFile = guessedName } } + Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } } -- ----------------------------------------------------------------------------- -- Targets @@ -448,6 +479,8 @@ guessTarget file (Just phase) guessTarget file Nothing | isHaskellSrcFilename file = return (Target (TargetFile file Nothing) Nothing) + | looksLikeModuleName file + = return (Target (TargetModule (mkModuleName file)) Nothing) | otherwise = do exists <- doesFileExist hs_file if exists @@ -457,7 +490,10 @@ guessTarget file Nothing if exists then return (Target (TargetFile lhs_file Nothing) Nothing) else do - return (Target (TargetModule (mkModuleName file)) Nothing) + throwGhcException + (ProgramError (showSDoc $ + text "target" <+> quotes (text file) <+> + text "is not a module name or a source file")) where hs_file = file <.> "hs" lhs_file = file <.> "lhs" @@ -545,7 +581,7 @@ data LoadHowMuch -- attempt to load up to this target. If no Module is supplied, -- then try to load all targets. load :: Session -> LoadHowMuch -> IO SuccessFlag -load s@(Session ref) how_much +load s how_much = do -- Dependency analysis first. Note that this fixes the module graph: -- even if we don't get a fully successful upsweep, the full module @@ -553,15 +589,8 @@ load s@(Session ref) how_much -- were successfully loaded by inspecting the Session's HPT. mb_graph <- depanal s [] False case mb_graph of - Just mod_graph -> catchingFailure $ load2 s how_much mod_graph + Just mod_graph -> load2 s how_much mod_graph Nothing -> return Failed - where catchingFailure f = f `Exception.catch` \e -> do - hsc_env <- readIORef ref - -- trac #1565 / test ghci021: - -- let bindings may explode if we try to use them after - -- failing to reload - writeIORef ref $! hsc_env{ hsc_IC = emptyInteractiveContext } - throw e load2 :: Session -> LoadHowMuch -> [ModSummary] -> IO SuccessFlag load2 s@(Session ref) how_much mod_graph = do @@ -581,6 +610,21 @@ load2 s@(Session ref) how_much mod_graph = do not (ms_mod_name s `elem` all_home_mods)] ASSERT( null bad_boot_mods ) return () + -- check that the module given in HowMuch actually exists, otherwise + -- topSortModuleGraph will bomb later. + let checkHowMuch (LoadUpTo m) = checkMod m + checkHowMuch (LoadDependenciesOf m) = checkMod m + checkHowMuch _ = id + + checkMod m and_then + | m `elem` all_home_mods = and_then + | otherwise = do + errorMsg dflags (text "no such module:" <+> + quotes (ppr m)) + return Failed + + checkHowMuch how_much $ do + -- mg2_with_srcimps drops the hi-boot nodes, returning a -- graph with cycles. Among other things, it is used for -- backing out partially complete cycles following a failed @@ -606,6 +650,12 @@ load2 s@(Session ref) how_much mod_graph = do evaluate pruned_hpt + -- before we unload anything, make sure we don't leave an old + -- interactive context around pointing to dead bindings. Also, + -- write the pruned HPT to allow the old HPT to be GC'd. + writeIORef ref $! hsc_env{ hsc_IC = emptyInteractiveContext, + hsc_HPT = pruned_hpt } + debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ text "Stable BCO:" <+> ppr stable_bco) @@ -974,7 +1024,7 @@ mkModGuts coreModule = ModGuts { mg_rules = [], mg_binds = cm_binds coreModule, mg_foreign = NoStubs, - mg_deprecs = NoDeprecs, + mg_warns = NoWarnings, mg_hpc_info = emptyHpcInfo False, mg_modBreaks = emptyModBreaks, mg_vect_info = noVectInfo, @@ -1530,7 +1580,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) @@ -1637,7 +1687,8 @@ downsweep :: HscEnv -- in which case there can be repeats downsweep hsc_env old_summaries excl_mods allow_dup_roots = -- catch error messages and return them - handleDyn (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do + handleErrMsg + (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do rootSummaries <- mapM getRootSummary roots let root_map = mkRootMap rootSummaries checkDuplicates root_map @@ -1654,7 +1705,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots = do exists <- doesFileExist file if exists then summariseFile hsc_env old_summaries file mb_phase maybe_buf - else throwDyn $ mkPlainErrMsg noSrcSpan $ + else throwErrMsg $ mkPlainErrMsg noSrcSpan $ text "can't find file:" <+> text file getRootSummary (Target (TargetModule modl) maybe_buf) = do maybe_summary <- summariseModule hsc_env old_summary_map False @@ -1760,7 +1811,10 @@ summariseFile hsc_env old_summaries file mb_phase maybe_buf if ms_hs_date old_summary == src_timestamp then do -- update the object-file timestamp - obj_timestamp <- getObjTimestamp location False + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) -- bug #1205 + then getObjTimestamp location False + else return Nothing return old_summary{ ms_obj_date = obj_timestamp } else new_summary @@ -1788,7 +1842,12 @@ summariseFile hsc_env old_summaries file mb_phase maybe_buf Nothing -> getModificationTime file -- getMofificationTime may fail - obj_timestamp <- modificationTimeIfExists (ml_obj_file location) + -- when the user asks to load a source file by name, we only + -- use an object file if -fobject-code is on. See #1205. + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + then modificationTimeIfExists (ml_obj_file location) + else return Nothing return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile, ms_location = location, @@ -1869,7 +1928,6 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc -- Drop external-pkg ASSERT(modulePackageId mod /= thisPackage dflags) return Nothing - where err -> noModError dflags loc wanted_mod err -- Not found @@ -1897,7 +1955,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn when (mod_name /= wanted_mod) $ - throwDyn $ mkPlainErrMsg mod_loc $ + throwErrMsg $ mkPlainErrMsg mod_loc $ text "File name does not match module name:" $$ text "Saw:" <+> quotes (ppr mod_name) $$ text "Expected:" <+> quotes (ppr wanted_mod) @@ -1938,8 +1996,9 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) let local_opts = getOptions dflags buf src_fn -- - (dflags', _errs) <- parseDynamicFlags dflags (map unLoc local_opts) - -- XXX: shouldn't we be reporting the errors? + (dflags', leftovers, warns) <- parseDynamicFlags dflags (map unLoc local_opts) + checkProcessArgsResult leftovers src_fn + handleFlagWarnings dflags' warns let needs_preprocessing @@ -1963,21 +2022,21 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab -- ToDo: we don't have a proper line number for this error noModError dflags loc wanted_mod err - = throwDyn $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err + = throwErrMsg $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err noHsFileErr :: SrcSpan -> String -> a noHsFileErr loc path - = throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path + = throwErrMsg $ mkPlainErrMsg loc $ text "Can't find" <+> text path packageModErr :: ModuleName -> a packageModErr mod - = throwDyn $ mkPlainErrMsg noSrcSpan $ + = throwErrMsg $ mkPlainErrMsg noSrcSpan $ text "module" <+> quotes (ppr mod) <+> text "is a package module" multiRootsErr :: [ModSummary] -> IO () multiRootsErr [] = panic "multiRootsErr" multiRootsErr summs@(summ1:_) - = throwDyn $ mkPlainErrMsg noSrcSpan $ + = throwErrMsg $ mkPlainErrMsg noSrcSpan $ text "module" <+> quotes (ppr mod) <+> text "is defined in multiple files:" <+> sep (map text files) @@ -2214,11 +2273,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 $ - text "module" <+> pprModule m <+> + | 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