X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=7ecc1942e9822733512951cc06ce1cd0137808ad;hp=7d3ef501e6c0cfc7890f384df50d7e9e2bdaefe7;hb=fc9bbbab3fe56cf0ff5723abbdb0f496d257f34e;hpb=59e7d08db602d243d3768ce6907e7bfe67a55e1a diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 7d3ef50..7ecc194 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,12 +239,13 @@ import CoreSyn import TidyPgm import DriverPipeline import DriverPhases ( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase ) -import HeaderInfo ( getImports, getOptions ) +import HeaderInfo import Finder import HscMain import HscTypes import DynFlags import StaticFlags +import StaticFlagParser import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept, cleanTempDirs ) import Module @@ -255,10 +256,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 +275,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 +294,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 +354,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 @@ -351,8 +374,8 @@ newSession mb_top_dir = do installSignalHandlers initStaticOpts - dflags0 <- initSysTools mb_top_dir defaultDynFlags - dflags <- initDynFlags dflags0 + dflags0 <- initDynFlags defaultDynFlags + dflags <- initSysTools mb_top_dir dflags0 env <- newHscEnv dflags ref <- newIORef env return (Session ref) @@ -393,16 +416,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 +480,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 +491,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 +582,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 +590,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 +611,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 +651,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 +1025,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, @@ -1481,22 +1532,16 @@ typecheckLoop hsc_env mods = do reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary] reachableBackwards mod summaries - = [ ms | (ms,_,_) <- map vertex_fn nodes_we_want ] - where - -- all the nodes reachable by traversing the edges backwards - -- from the root node: - nodes_we_want = reachable (transposeG graph) root - - -- the rest just sets up the graph: - (nodes, lookup_key) = moduleGraphNodes False summaries - (graph, vertex_fn, key_fn) = graphFromEdges' nodes - root - | Just key <- lookup_key HsBootFile mod, Just v <- key_fn key = v - | otherwise = panic "reachableBackwards" + = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ] + where -- the rest just sets up the graph: + (graph, lookup_node) = moduleGraphNodes False summaries + root = expectJust "reachableBackwards" (lookup_node HsBootFile mod) -- --------------------------------------------------------------------------- -- Topological sort of the module graph +type SummaryNode = (ModSummary, Int, [Int]) + topSortModuleGraph :: Bool -- Drop hi-boot nodes? (see below) -> [ModSummary] @@ -1517,66 +1562,75 @@ topSortModuleGraph -- the a source-import of Foo is an import of Foo -- The resulting graph has no hi-boot nodes, but can by cyclic -topSortModuleGraph drop_hs_boot_nodes summaries Nothing - = stronglyConnComp (fst (moduleGraphNodes drop_hs_boot_nodes summaries)) -topSortModuleGraph drop_hs_boot_nodes summaries (Just mod) - = stronglyConnComp (map vertex_fn (reachable graph root)) - where - -- restrict the graph to just those modules reachable from - -- the specified module. We do this by building a graph with - -- the full set of nodes, and determining the reachable set from - -- the specified node. - (nodes, lookup_key) = moduleGraphNodes drop_hs_boot_nodes summaries - (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") +topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod + = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph + where + (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries + + initial_graph = case mb_root_mod of + Nothing -> graph + Just root_mod -> + -- restrict the graph to just those modules reachable from + -- the specified module. We do this by building a graph with + -- the full set of nodes, and determining the reachable set from + -- the specified node. + let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node + | otherwise = ghcError (ProgramError "module does not exist") + in graphFromEdgedVertices (seq root (reachableG graph root)) + +summaryNodeKey :: SummaryNode -> Int +summaryNodeKey (_, k, _) = k + +summaryNodeSummary :: SummaryNode -> ModSummary +summaryNodeSummary (s, _, _) = s moduleGraphNodes :: Bool -> [ModSummary] - -> ([(ModSummary, Int, [Int])], HscSource -> ModuleName -> Maybe Int) -moduleGraphNodes drop_hs_boot_nodes summaries = (nodes, lookup_key) - where - -- Drop hs-boot nodes by using HsSrcFile as the key - hs_boot_key | drop_hs_boot_nodes = HsSrcFile - | otherwise = HsBootFile - - -- We use integers as the keys for the SCC algorithm - nodes :: [(ModSummary, Int, [Int])] - nodes = [(s, expectJust "topSort" $ - lookup_key (ms_hsc_src s) (ms_mod_name s), - out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++ - out_edge_keys HsSrcFile (map unLoc (ms_imps s)) ++ - (-- see [boot-edges] below - if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile - then [] - else case lookup_key HsBootFile (ms_mod_name s) of - Nothing -> [] - Just k -> [k]) - ) - | s <- summaries - , not (isBootSummary s && drop_hs_boot_nodes) ] - -- Drop the hi-boot ones if told to do so - - -- [boot-edges] if this is a .hs and there is an equivalent - -- .hs-boot, add a link from the former to the latter. This - -- has the effect of detecting bogus cases where the .hs-boot - -- depends on the .hs, by introducing a cycle. Additionally, - -- it ensures that we will always process the .hs-boot before - -- the .hs, and so the HomePackageTable will always have the - -- most up to date information. - - key_map :: NodeMap Int - key_map = listToFM ([(moduleName (ms_mod s), ms_hsc_src s) - | s <- summaries] - `zip` [1..]) - - lookup_key :: HscSource -> ModuleName -> Maybe Int - lookup_key hs_src mod = lookupFM key_map (mod, hs_src) - - out_edge_keys :: HscSource -> [ModuleName] -> [Int] - out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms - -- If we want keep_hi_boot_nodes, then we do lookup_key with - -- the IsBootInterface parameter True; else False + -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode) +moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node) + where + numbered_summaries = zip summaries [1..] + + lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode + lookup_node hs_src mod = lookupFM node_map (mod, hs_src) + + lookup_key :: HscSource -> ModuleName -> Maybe Int + lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod) + + node_map :: NodeMap SummaryNode + node_map = listToFM [ ((moduleName (ms_mod s), ms_hsc_src s), node) + | node@(s, _, _) <- nodes ] + + -- We use integers as the keys for the SCC algorithm + nodes :: [SummaryNode] + nodes = [ (s, key, out_keys) + | (s, key) <- numbered_summaries + -- Drop the hi-boot ones if told to do so + , not (isBootSummary s && drop_hs_boot_nodes) + , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++ + out_edge_keys HsSrcFile (map unLoc (ms_imps s)) ++ + (-- see [boot-edges] below + if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile + then [] + else case lookup_key HsBootFile (ms_mod_name s) of + Nothing -> [] + Just k -> [k]) ] + + -- [boot-edges] if this is a .hs and there is an equivalent + -- .hs-boot, add a link from the former to the latter. This + -- has the effect of detecting bogus cases where the .hs-boot + -- depends on the .hs, by introducing a cycle. Additionally, + -- it ensures that we will always process the .hs-boot before + -- the .hs, and so the HomePackageTable will always have the + -- most up to date information. + + -- Drop hs-boot nodes by using HsSrcFile as the key + hs_boot_key | drop_hs_boot_nodes = HsSrcFile + | otherwise = HsBootFile + + out_edge_keys :: HscSource -> [ModuleName] -> [Int] + out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms + -- If we want keep_hi_boot_nodes, then we do lookup_key with + -- the IsBootInterface parameter True; else False type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are @@ -1637,7 +1691,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 +1709,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 +1815,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 +1846,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 +1932,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 +1959,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 +2000,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 local_opts + checkProcessArgsResult leftovers + handleFlagWarnings dflags' warns let needs_preprocessing @@ -1963,21 +2026,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) @@ -2153,7 +2216,7 @@ isDictonaryId id -- 'setContext'. lookupGlobalName :: Session -> Name -> IO (Maybe TyThing) lookupGlobalName s name = withSession s $ \hsc_env -> do - eps <- readIORef (hsc_EPS hsc_env) + eps <- hscEPS hsc_env return $! lookupType (hsc_dflags hsc_env) (hsc_HPT hsc_env) (eps_PTE eps) name @@ -2201,7 +2264,7 @@ getTokenStream :: Session -> Module -> IO [Located Token] -- | Takes a 'ModuleName' and possibly a 'PackageId', and consults the -- filesystem and package database to find the corresponding 'Module', -- using the algorithm that is used for an @import@ declaration. -findModule :: Session -> ModuleName -> Maybe PackageId -> IO Module +findModule :: Session -> ModuleName -> Maybe FastString -> IO Module findModule s mod_name maybe_pkg = withSession s $ \hsc_env -> let dflags = hsc_dflags hsc_env @@ -2214,11 +2277,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