X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=b29912e916a1e2e392da30ebdd1be72f226f2233;hb=3d73e45b0909b9669d4679cbda29fa2b17b98d2e;hp=03ad6deaea80ca1e69c8fe47a1c46fcf252676e1;hpb=806ab6331b967d6176b8790a0b1b551ec0e8e2b6;p=ghc-hetmet.git diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 03ad6de..b29912e 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -41,7 +41,8 @@ module GHC ( workingDirectoryChanged, checkModule, checkAndLoadModule, CheckedModule(..), TypecheckedSource, ParsedSource, RenamedSource, - compileToCore, compileToCoreModule, + compileToCore, compileToCoreModule, compileToCoreSimplified, + compileCoreToObj, -- * Parsing Haddock comments parseHaddockComment, @@ -217,11 +218,12 @@ import TcRnMonad ( initIfaceCheck ) import Packages import NameSet import RdrName -import HsSyn +import qualified HsSyn -- hack as we want to reexport the whole module +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 @@ -229,31 +231,32 @@ import FunDeps import DataCon import Name hiding ( varName ) import OccName ( parenSymOcc ) -import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr ) +import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr, + emptyInstEnv ) +import FamInstEnv ( emptyFamInstEnv ) import SrcLoc 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 -import UniqFM +import LazyUniqFM import UniqSet import Unique 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 @@ -261,19 +264,25 @@ import BasicTypes import Maybes ( expectJust, mapCatMaybes ) import HaddockParse import HaddockLex ( tokenise ) +import FastString import Control.Concurrent -import System.Directory ( getModificationTime, doesFileExist ) +import System.Directory ( getModificationTime, doesFileExist, + getCurrentDirectory ) import Data.Maybe import Data.List import qualified Data.List as List import Control.Monad import System.Exit ( exitWith, ExitCode(..) ) -import System.Time ( ClockTime ) -import Control.Exception as Exception hiding (handle) +import System.Time ( ClockTime, getClockTime ) +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) @@ -285,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 @@ -323,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 @@ -343,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) @@ -385,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 basenameOf 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 @@ -423,7 +463,7 @@ removeTarget :: Session -> TargetId -> IO () removeTarget s target_id = modifySession s (\h -> h{ hsc_targets = filter (hsc_targets h) }) where - filter targets = [ t | t@(Target id _) <- targets, id /= target_id ] + filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ] -- Attempts to guess what Target a string refers to. This function implements -- the --make/GHCi command-line syntax for filenames: @@ -435,24 +475,36 @@ removeTarget s target_id -- - otherwise interpret the string as a module name -- guessTarget :: String -> Maybe Phase -> IO Target -guessTarget file (Just phase) - = return (Target (TargetFile file (Just phase)) Nothing) -guessTarget file Nothing +guessTarget str (Just phase) + = return (Target (TargetFile str (Just phase)) True Nothing) +guessTarget str Nothing | isHaskellSrcFilename file - = return (Target (TargetFile file Nothing) Nothing) + = return (target (TargetFile file Nothing)) | otherwise = do exists <- doesFileExist hs_file if exists - then return (Target (TargetFile hs_file Nothing) Nothing) + then return (target (TargetFile hs_file Nothing)) else do exists <- doesFileExist lhs_file if exists - then return (Target (TargetFile lhs_file Nothing) Nothing) + then return (target (TargetFile lhs_file Nothing)) else do - return (Target (TargetModule (mkModuleName file)) Nothing) + if looksLikeModuleName file + then return (target (TargetModule (mkModuleName file))) + else do + throwGhcException + (ProgramError (showSDoc $ + text "target" <+> quotes (text file) <+> + text "is not a module name or a source file")) where - hs_file = file `joinFileExt` "hs" - lhs_file = file `joinFileExt` "lhs" + (file,obj_allowed) + | '*':rest <- str = (rest, False) + | otherwise = (str, True) + + hs_file = file <.> "hs" + lhs_file = file <.> "lhs" + + target tid = Target tid obj_allowed Nothing -- ----------------------------------------------------------------------------- -- Extending the program scope @@ -483,7 +535,10 @@ setGlobalTypeScope session ids -- Parsing Haddock comments parseHaddockComment :: String -> Either String (HsDoc RdrName) -parseHaddockComment string = parseHaddockParagraphs (tokenise string) +parseHaddockComment string = + case parseHaddockParagraphs (tokenise string) of + MyLeft x -> Left x + MyRight x -> Right x -- ----------------------------------------------------------------------------- -- Loading the program @@ -534,7 +589,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 @@ -542,15 +597,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 @@ -570,6 +618,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 @@ -595,6 +658,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) @@ -774,7 +843,7 @@ data CheckedModule = renamedSource :: Maybe RenamedSource, typecheckedSource :: Maybe TypecheckedSource, checkedModuleInfo :: Maybe ModuleInfo, - coreModule :: Maybe CoreModule + coreModule :: Maybe ModGuts } -- ToDo: improvements that could be made here: -- if the module succeeded renaming but not typechecking, @@ -864,12 +933,6 @@ checkModule_ ref ms compile_to_core load then deSugarModule hsc_env ms tcg else return Nothing - let mb_core = fmap (\ mg -> - CoreModule { cm_module = mg_module mg, - cm_types = mg_types mg, - cm_binds = mg_binds mg }) - mb_guts - -- If we are loading this module so that we can typecheck -- dependent modules, generate an interface and stuff it -- all in the HomePackageTable. @@ -887,7 +950,7 @@ checkModule_ ref ms compile_to_core load renamedSource = rn_info, typecheckedSource = Just tc_binds, checkedModuleInfo = Just minf, - coreModule = mb_core })) + coreModule = mb_guts })) -- | This is the way to get access to the Core bindings corresponding -- to a module. 'compileToCore' invokes 'checkModule' to parse, typecheck, and @@ -895,7 +958,90 @@ checkModule_ ref ms compile_to_core load -- the module name, type declarations, and function declarations) if -- successful. compileToCoreModule :: Session -> FilePath -> IO (Maybe CoreModule) -compileToCoreModule session fn = do +compileToCoreModule = compileCore False + +-- | Like compileToCoreModule, but invokes the simplifier, so +-- as to return simplified and tidied Core. +compileToCoreSimplified :: Session -> FilePath -> IO (Maybe CoreModule) +compileToCoreSimplified = compileCore True + +-- | Provided for backwards-compatibility: compileToCore returns just the Core +-- bindings, but for most purposes, you probably want to call +-- compileToCoreModule. +compileToCore :: Session -> FilePath -> IO (Maybe [CoreBind]) +compileToCore session fn = do + maybeCoreModule <- compileToCoreModule session fn + return $ fmap cm_binds maybeCoreModule + +-- | Takes a CoreModule and compiles the bindings therein +-- to object code. The first argument is a bool flag indicating +-- whether to run the simplifier. +-- The resulting .o, .hi, and executable files, if any, are stored in the +-- current directory, and named according to the module name. +-- Returns True iff compilation succeeded. +-- This has only so far been tested with a single self-contained module. +compileCoreToObj :: Bool -> Session -> CoreModule -> IO Bool +compileCoreToObj simplify session cm@(CoreModule{ cm_module = mName }) = do + hscEnv <- sessionHscEnv session + dflags <- getSessionDynFlags session + currentTime <- getClockTime + cwd <- getCurrentDirectory + modLocation <- mkHiOnlyModLocation dflags (hiSuf dflags) cwd + ((moduleNameSlashes . moduleName) mName) + + let modSummary = ModSummary { ms_mod = mName, + ms_hsc_src = ExtCoreFile, + ms_location = modLocation, + -- By setting the object file timestamp to Nothing, + -- we always force recompilation, which is what we + -- want. (Thus it doesn't matter what the timestamp + -- for the (nonexistent) source file is.) + ms_hs_date = currentTime, + ms_obj_date = Nothing, + -- Only handling the single-module case for now, so no imports. + ms_srcimps = [], + ms_imps = [], + -- No source file + ms_hspp_file = "", + ms_hspp_opts = dflags, + ms_hspp_buf = Nothing + } + + mbHscResult <- evalComp + ((if simplify then hscSimplify else return) (mkModGuts cm) + >>= hscNormalIface >>= hscWriteIface >>= hscOneShot) + (CompState{ compHscEnv=hscEnv, + compModSummary=modSummary, + compOldIface=Nothing}) + return $ isJust mbHscResult + +-- Makes a "vanilla" ModGuts. +mkModGuts :: CoreModule -> ModGuts +mkModGuts coreModule = ModGuts { + mg_module = cm_module coreModule, + mg_boot = False, + mg_exports = [], + mg_deps = noDependencies, + mg_dir_imps = emptyModuleEnv, + mg_used_names = emptyNameSet, + mg_rdr_env = emptyGlobalRdrEnv, + mg_fix_env = emptyFixityEnv, + mg_types = emptyTypeEnv, + mg_insts = [], + mg_fam_insts = [], + mg_rules = [], + mg_binds = cm_binds coreModule, + mg_foreign = NoStubs, + mg_warns = NoWarnings, + mg_hpc_info = emptyHpcInfo False, + mg_modBreaks = emptyModBreaks, + mg_vect_info = noVectInfo, + mg_inst_env = emptyInstEnv, + mg_fam_inst_env = emptyFamInstEnv +} + +compileCore :: Bool -> Session -> FilePath -> IO (Maybe CoreModule) +compileCore simplify session fn = do -- First, set the target to the desired filename target <- guessTarget fn Nothing addTarget session target @@ -913,17 +1059,34 @@ compileToCoreModule session fn = do maybeCheckedModule <- checkModule session mod True case maybeCheckedModule of Nothing -> return Nothing - Just checkedMod -> return $ coreModule checkedMod + Just checkedMod -> (liftM $ fmap gutsToCoreModule) $ + case (coreModule checkedMod) of + Just mg | simplify -> (sessionHscEnv session) + -- If simplify is true: simplify (hscSimplify), + -- then tidy (tidyProgram). + >>= \ hscEnv -> evalComp (hscSimplify mg) + (CompState{ compHscEnv=hscEnv, + compModSummary=modSummary, + compOldIface=Nothing}) + >>= (tidyProgram hscEnv) + >>= (return . Just . Left) + Just guts -> return $ Just $ Right guts + Nothing -> return Nothing Nothing -> panic "compileToCoreModule: target FilePath not found in\ module dependency graph" + where -- two versions, based on whether we simplify (thus run tidyProgram, + -- which returns a (CgGuts, ModDetails) pair, or not (in which case + -- we just have a ModGuts. + gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule + gutsToCoreModule (Left (cg, md)) = CoreModule { + cm_module = cg_module cg, cm_types = md_types md, + cm_imports = cg_dir_imps cg, cm_binds = cg_binds cg + } + gutsToCoreModule (Right mg) = CoreModule { + cm_module = mg_module mg, cm_types = mg_types mg, + cm_imports = moduleEnvKeys (mg_dir_imps mg), cm_binds = mg_binds mg + } --- | Provided for backwards-compatibility: compileToCore returns just the Core --- bindings, but for most purposes, you probably want to call --- compileToCoreModule. -compileToCore :: Session -> FilePath -> IO (Maybe [CoreBind]) -compileToCore session fn = do - maybeCoreModule <- compileToCoreModule session fn - return $ fmap cm_binds maybeCoreModule -- --------------------------------------------------------------------------- -- Unloading @@ -1150,7 +1313,7 @@ upsweep hsc_env old_hpt stable_mods cleanup sccs = do cleanup -- Remove unwanted tmp files between compilations case mb_mod_info of - Nothing -> return (Failed, hsc_env, []) + Nothing -> return (Failed, hsc_env, done) Just mod_info -> do let this_mod = ms_mod_name mod @@ -1376,22 +1539,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] @@ -1412,66 +1569,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 @@ -1501,7 +1667,7 @@ warnUnnecessarySourceImports dflags sccs = warn :: Located ModuleName -> WarnMsg warn (L loc mod) = mkPlainErrMsg loc - (ptext SLIT("Warning: {-# SOURCE #-} unnecessary in import of ") + (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ") <+> quotes (ppr mod)) ----------------------------------------------------------------------------- @@ -1532,7 +1698,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 @@ -1545,20 +1712,22 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots old_summary_map = mkNodeMap old_summaries getRootSummary :: Target -> IO ModSummary - getRootSummary (Target (TargetFile file mb_phase) maybe_buf) + getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf) = do exists <- doesFileExist file if exists - then summariseFile hsc_env old_summaries file mb_phase maybe_buf - else throwDyn $ mkPlainErrMsg noSrcSpan $ + then summariseFile hsc_env old_summaries file mb_phase + obj_allowed maybe_buf + else throwErrMsg $ mkPlainErrMsg noSrcSpan $ text "can't find file:" <+> text file - getRootSummary (Target (TargetModule modl) maybe_buf) + getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) = do maybe_summary <- summariseModule hsc_env old_summary_map False - (L rootLoc modl) maybe_buf excl_mods + (L rootLoc modl) obj_allowed + maybe_buf excl_mods case maybe_summary of Nothing -> packageModErr modl Just s -> return s - rootLoc = mkGeneralSrcSpan FSLIT("") + rootLoc = mkGeneralSrcSpan (fsLit "") -- In a root module, the filename is allowed to diverge from the module -- name, so we have to check that there aren't multiple root files @@ -1589,12 +1758,13 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots loop ss done else do { multiRootsErr summs; return [] } - | otherwise = do { mb_s <- summariseModule hsc_env old_summary_map - is_boot wanted_mod Nothing excl_mods - ; case mb_s of - Nothing -> loop ss done - Just s -> loop (msDeps s ++ ss) - (addToFM done key [s]) } + | otherwise + = do mb_s <- summariseModule hsc_env old_summary_map + is_boot wanted_mod True + Nothing excl_mods + case mb_s of + Nothing -> loop ss done + Just s -> loop (msDeps s ++ ss) (addToFM done key [s]) where key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile) @@ -1633,10 +1803,11 @@ summariseFile -> [ModSummary] -- old summaries -> FilePath -- source file name -> Maybe Phase -- start phase + -> Bool -- object code allowed? -> Maybe (StringBuffer,ClockTime) -> IO ModSummary -summariseFile hsc_env old_summaries file mb_phase maybe_buf +summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf -- we can use a cached summary if one is available and the -- source file hasn't changed, But we have to look up the summary -- by source file, rather than module name as we do in summarise. @@ -1655,7 +1826,11 @@ 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)) + || obj_allowed -- bug #1205 + then getObjTimestamp location False + else return Nothing return old_summary{ ms_obj_date = obj_timestamp } else new_summary @@ -1667,7 +1842,7 @@ summariseFile hsc_env old_summaries file mb_phase maybe_buf let dflags = hsc_dflags hsc_env (dflags', hspp_fn, buf) - <- preprocessFile dflags file mb_phase maybe_buf + <- preprocessFile hsc_env file mb_phase maybe_buf (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file @@ -1683,7 +1858,13 @@ 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)) + || obj_allowed -- bug #1205 + then modificationTimeIfExists (ml_obj_file location) + else return Nothing return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile, ms_location = location, @@ -1707,11 +1888,13 @@ summariseModule -> NodeMap ModSummary -- Map of old summaries -> IsBootInterface -- True <=> a {-# SOURCE #-} import -> Located ModuleName -- Imported module to be summarised + -> Bool -- object code allowed? -> Maybe (StringBuffer, ClockTime) -> [ModuleName] -- Modules to exclude -> IO (Maybe ModSummary) -- Its new summary -summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf excl_mods +summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) + obj_allowed maybe_buf excl_mods | wanted_mod `elem` excl_mods = return Nothing @@ -1742,7 +1925,11 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc check_timestamp old_summary location src_fn src_timestamp | ms_hs_date old_summary == src_timestamp = do -- update the object-file timestamp - obj_timestamp <- getObjTimestamp location is_boot + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then getObjTimestamp location is_boot + else return Nothing return (Just old_summary{ ms_obj_date = obj_timestamp }) | otherwise = -- source changed: re-summarise. @@ -1764,7 +1951,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 @@ -1788,16 +1974,22 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc = do -- Preprocess the source file and get its imports -- The dflags' contains the OPTIONS pragmas - (dflags', hspp_fn, buf) <- preprocessFile dflags src_fn Nothing maybe_buf + (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn when (mod_name /= wanted_mod) $ - throwDyn $ mkPlainErrMsg mod_loc $ - text "file name does not match module name" - <+> quotes (ppr mod_name) + throwErrMsg $ mkPlainErrMsg mod_loc $ + text "File name does not match module name:" + $$ text "Saw:" <+> quotes (ppr mod_name) + $$ text "Expected:" <+> quotes (ppr wanted_mod) -- Find the object timestamp, and return the summary - obj_timestamp <- getObjTimestamp location is_boot + + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then getObjTimestamp location is_boot + else return Nothing return (Just ( ModSummary { ms_mod = mod, ms_hsc_src = hsc_src, @@ -1817,22 +2009,24 @@ getObjTimestamp location is_boot else modificationTimeIfExists (ml_obj_file location) -preprocessFile :: DynFlags -> FilePath -> Maybe Phase -> Maybe (StringBuffer,ClockTime) +preprocessFile :: HscEnv -> FilePath -> Maybe Phase -> Maybe (StringBuffer,ClockTime) -> IO (DynFlags, FilePath, StringBuffer) -preprocessFile dflags src_fn mb_phase Nothing +preprocessFile hsc_env src_fn mb_phase Nothing = do - (dflags', hspp_fn) <- preprocess dflags (src_fn, mb_phase) + (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase) buf <- hGetStringBuffer hspp_fn return (dflags', hspp_fn, buf) -preprocessFile dflags src_fn mb_phase (Just (buf, _time)) +preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) = do + let dflags = hsc_dflags hsc_env -- case we bypass the preprocessing stage? let - local_opts = getOptions buf src_fn + 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 @@ -1856,21 +2050,21 @@ preprocessFile dflags 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) @@ -1880,11 +2074,11 @@ multiRootsErr summs@(summ1:_) cyclicModuleErr :: [ModSummary] -> SDoc cyclicModuleErr ms - = hang (ptext SLIT("Module imports form a cycle for modules:")) + = hang (ptext (sLit "Module imports form a cycle for modules:")) 2 (vcat (map show_one ms)) where show_one ms = sep [ show_mod (ms_hsc_src ms) (ms_mod ms), - nest 2 $ ptext SLIT("imports:") <+> + nest 2 $ ptext (sLit "imports:") <+> (pp_imps HsBootFile (ms_srcimps ms) $$ pp_imps HsSrcFile (ms_imps ms))] show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src) @@ -2046,7 +2240,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 @@ -2094,7 +2288,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 @@ -2107,11 +2301,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