X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=e402d895212b20e9fceba57170dbb8e7a643cabc;hb=0a5613f40b0e32cf59966e6b56b807cdbe80aa7b;hp=5d6f034db5825e95e9a531d806245cbdbb482a41;hpb=8305bb1641490429912a8ac5c3b1265a21937689;p=ghc-hetmet.git diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 5d6f034..e402d89 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -58,9 +58,6 @@ module GHC ( compileCoreToObj, getModSummary, - -- * Parsing Haddock comments - parseHaddockComment, - -- * Inspecting the module structure of the program ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..), getModuleGraph, @@ -89,6 +86,7 @@ module GHC ( -- * Interactive evaluation getBindings, getPrintUnqual, findModule, + lookupModule, #ifdef GHCI setContext, getContext, getNamesInScope, @@ -244,7 +242,6 @@ import qualified Linker import Linker ( HValue ) import ByteCodeInstr import BreakArray -import NameSet import InteractiveEval import TcRnDriver #endif @@ -257,17 +254,17 @@ import NameSet import RdrName import qualified HsSyn -- hack as we want to reexport the whole module import HsSyn hiding ((<.>)) -import Type hiding (typeKind) -import TcType hiding (typeKind) +import Type +import TcType hiding( typeKind ) import Id import Var import TysPrim ( alphaTyVars ) import TyCon import Class -import FunDeps +-- import FunDeps import DataCon import Name hiding ( varName ) -import OccName ( parenSymOcc ) +-- import OccName ( parenSymOcc ) import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr, emptyInstEnv ) import FamInstEnv ( emptyFamInstEnv ) @@ -275,7 +272,7 @@ import SrcLoc --import CoreSyn import TidyPgm import DriverPipeline -import DriverPhases ( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase ) +import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase ) import HeaderInfo import Finder import HscMain @@ -289,8 +286,6 @@ import Annotations import Module import LazyUniqFM import qualified UniqFM as UFM -import UniqSet -import Unique import FiniteMap import Panic import Digraph @@ -302,12 +297,9 @@ import StringBuffer ( StringBuffer, hGetStringBuffer, nextChar ) import Outputable import BasicTypes import Maybes ( expectJust, mapCatMaybes ) -import HaddockParse -import HaddockLex ( tokenise ) import FastString import Lexer -import Control.Concurrent import System.Directory ( getModificationTime, doesFileExist, getCurrentDirectory ) import Data.Maybe @@ -360,6 +352,7 @@ defaultErrorHandler dflags inner = case ge of PhaseFailed _ code -> exitWith code Interrupted -> exitWith (ExitFailure 1) + Signal _ -> exitWith (ExitFailure 1) _ -> do fatalErrorMsg dflags (text (show ge)) exitWith (ExitFailure 1) ) $ @@ -373,7 +366,7 @@ defaultCleanupHandler :: (ExceptionMonad m, MonadIO m) => DynFlags -> m a -> m a defaultCleanupHandler dflags inner = -- make sure we clean up after ourselves - inner `gonException` + inner `gfinally` (liftIO $ do cleanTempFiles dflags cleanTempDirs dflags @@ -461,8 +454,6 @@ runGhcT mb_top_dir ghct = do initGhcMonad :: GhcMonad m => Maybe FilePath -> m () initGhcMonad mb_top_dir = do -- catch ^C - main_thread <- liftIO $ myThreadId - liftIO $ modifyMVar_ interruptTargetThread (return . (main_thread :)) liftIO $ installSignalHandlers liftIO $ StaticFlags.initStaticOpts @@ -628,15 +619,6 @@ setGlobalTypeScope ids hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids } -- ----------------------------------------------------------------------------- --- Parsing Haddock comments - -parseHaddockComment :: String -> Either String (HsDoc RdrName) -parseHaddockComment string = - case parseHaddockParagraphs (tokenise string) of - MyLeft x -> Left x - MyRight x -> Right x - --- ----------------------------------------------------------------------------- -- Loading the program -- | Perform a dependency analysis starting from the current targets @@ -785,7 +767,7 @@ load2 how_much mod_graph = do (flattenSCCs mg2_with_srcimps) stable_mods - liftIO $ evaluate pruned_hpt + _ <- liftIO $ evaluate pruned_hpt -- before we unload anything, make sure we don't leave an old -- interactive context around pointing to dead bindings. Also, @@ -889,7 +871,7 @@ load2 how_much mod_graph = do let main_mod = mainModIs dflags a_root_is_Main = any ((==main_mod).ms_mod) mod_graph - do_linking = a_root_is_Main || no_hs_main + do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib when (ghcLink dflags == LinkBinary && isJust ofile && not do_linking) $ @@ -1037,7 +1019,7 @@ instance DesugaredMod DesugaredModule where type ParsedSource = Located (HsModule RdrName) type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], - Maybe (HsDoc Name), HaddockModInfo Name) + Maybe LHsDocString) type TypecheckedSource = LHsBinds Id -- NOTE: @@ -1120,30 +1102,46 @@ desugarModule tcm = do -- | Load a module. Input doesn't need to be desugared. -- --- XXX: Describe usage. +-- A module must be loaded before dependent modules can be typechecked. This +-- always includes generating a 'ModIface' and, depending on the +-- 'DynFlags.hscTarget', may also include code generation. +-- +-- This function will always cause recompilation and will always overwrite +-- previous compilation results (potentially files on disk). +-- loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod loadModule tcm = do let ms = modSummary tcm let mod = ms_mod_name ms + let loc = ms_location ms let (tcg, _details) = tm_internals tcm hpt_new <- withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do let compilerBackend comp env ms' _ _mb_old_iface _ = withTempSession (\_ -> env) $ - hscBackend comp tcg ms' - Nothing + hscBackend comp tcg ms' Nothing + hsc_env <- getSession - mod_info - <- compile' (compilerBackend hscNothingCompiler - ,compilerBackend hscInteractiveCompiler - ,compilerBackend hscBatchCompiler) - hsc_env ms 1 1 Nothing Nothing + mod_info <- do + mb_linkable <- + case ms_obj_date ms of + Just t | t > ms_hs_date ms -> do + l <- liftIO $ findObjectLinkable (ms_mod ms) + (ml_obj_file loc) t + return (Just l) + _otherwise -> return Nothing + + compile' (compilerBackend hscNothingCompiler + ,compilerBackend hscInteractiveCompiler + ,hscCheckRecompBackend hscBatchCompiler tcg) + hsc_env ms 1 1 Nothing mb_linkable -- compile' shouldn't change the environment return $ addToUFM (hsc_HPT hsc_env) mod mod_info modifySession $ \e -> e{ hsc_HPT = hpt_new } return tcm + -- | This is the way to get access to the Core bindings corresponding -- to a module. 'compileToCore' parses, typechecks, and -- desugars the module, then returns the resulting Core module (consisting of @@ -1203,7 +1201,7 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do (iface, changed, _details, cgguts) <- hscNormalIface guts Nothing hscWriteIface iface changed modSummary - hscGenHardCode cgguts modSummary + _ <- hscGenHardCode cgguts modSummary return () -- Makes a "vanilla" ModGuts. @@ -1237,7 +1235,7 @@ compileCore simplify fn = do -- First, set the target to the desired filename target <- guessTarget fn Nothing addTarget target - load LoadAllTargets + _ <- load LoadAllTargets -- Then find dependencies modGraph <- depanal [] True case find ((== fn) . msHsFilePath) modGraph of @@ -2328,18 +2326,28 @@ cyclicModuleErr ms = 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:") <+> - (pp_imps HsBootFile (ms_srcimps ms) - $$ pp_imps HsSrcFile (ms_imps ms))] + mods_in_cycle = map ms_mod_name ms + imp_modname = unLoc . ideclName . unLoc + just_in_cycle = filter ((`elem` mods_in_cycle) . imp_modname) + + show_one ms = + vcat [ show_mod (ms_hsc_src ms) (ms_mod_name ms) <+> + maybe empty (parens . text) (ml_hs_file (ms_location ms)), + nest 2 $ ptext (sLit "imports:") <+> vcat [ + pp_imps HsBootFile (just_in_cycle $ ms_srcimps ms), + pp_imps HsSrcFile (just_in_cycle $ ms_imps ms) ] + ] show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src) - pp_imps src mods = fsep (map (show_mod src) mods) + pp_imps src imps = fsep (map (show_mod src . unLoc . ideclName . unLoc) imps) -- | Inform GHC that the working directory has changed. GHC will flush -- its cache of module locations, since it may no longer be valid. --- Note: if you change the working directory, you should also unload --- the current program (set targets to empty, followed by load). +-- +-- Note: Before changing the working directory make sure all threads running +-- in the same session have stopped. If you change the working directory, +-- you should also unload the current program (set targets to empty, +-- followed by load). workingDirectoryChanged :: GhcMonad m => m () workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches) @@ -2370,14 +2378,10 @@ getBindings = withSession $ \hsc_env -> -- we have to implement the shadowing behaviour of ic_tmp_ids here -- (see InteractiveContext) and the quickest way is to use an OccEnv. let - tmp_ids = ic_tmp_ids (hsc_IC hsc_env) - filtered = foldr f (const []) tmp_ids emptyUniqSet - f id rest set - | uniq `elementOfUniqSet` set = rest set - | otherwise = AnId id : rest (addOneToUniqSet set uniq) - where uniq = getUnique (nameOccName (idName id)) + occ_env = mkOccEnv [ (nameOccName (idName id), AnId id) + | id <- ic_tmp_ids (hsc_IC hsc_env) ] in - return filtered + return (occEnvElts occ_env) getPrintUnqual :: GhcMonad m => m PrintUnqualified getPrintUnqual = withSession $ \hsc_env -> @@ -2533,7 +2537,7 @@ packageDbModules only_exposed = do return $ [ mkModule pid modname | p <- pkgs , not only_exposed || exposed p - , pid <- [mkPackageId (package p)] + , let pid = packageConfigId p , modname <- exposedModules p ] -- ----------------------------------------------------------------------------- @@ -2584,7 +2588,7 @@ getModuleSourceAndFlags mod = do getTokenStream :: GhcMonad m => Module -> m [Located Token] getTokenStream mod = do (sourceFile, source, flags) <- getModuleSourceAndFlags mod - let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0 + let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1 case lexTokenStream source startLoc flags of POk _ ts -> return ts PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err) @@ -2595,7 +2599,7 @@ getTokenStream mod = do getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)] getRichTokenStream mod = do (sourceFile, source, flags) <- getModuleSourceAndFlags mod - let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0 + let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1 case lexTokenStream source startLoc flags of POk _ ts -> return $ addSourceToTokens startLoc source ts PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err) @@ -2626,7 +2630,7 @@ addSourceToTokens loc buf (t@(L span _) : ts) showRichTokenStream :: [(Located Token, String)] -> String showRichTokenStream ts = go startLoc ts "" where sourceFile = srcSpanFile (getLoc . fst . head $ ts) - startLoc = mkSrcLoc sourceFile 0 0 + startLoc = mkSrcLoc sourceFile 1 1 go _ [] = id go loc ((L span _, str):ts) | not (isGoodSrcSpan span) = go loc ts @@ -2648,23 +2652,58 @@ showRichTokenStream ts = go startLoc ts "" -- filesystem and package database to find the corresponding 'Module', -- using the algorithm that is used for an @import@ declaration. findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module -findModule mod_name maybe_pkg = withSession $ \hsc_env -> liftIO $ -- XXX - let - dflags = hsc_dflags hsc_env - hpt = hsc_HPT hsc_env - this_pkg = thisPackage dflags - in - case lookupUFM hpt mod_name of - Just mod_info -> return (mi_module (hm_iface mod_info)) - _not_a_home_module -> do - res <- findImportedModule hsc_env mod_name maybe_pkg - case res of - Found _ m | modulePackageId m /= this_pkg -> return m - | otherwise -> ghcError (CmdLineError (showSDoc $ - text "module" <+> quotes (ppr (moduleName m)) <+> - text "is not loaded")) - err -> let msg = cannotFindModule dflags mod_name err in - ghcError (CmdLineError (showSDoc msg)) +findModule mod_name maybe_pkg = withSession $ \hsc_env -> do + let + dflags = hsc_dflags hsc_env + this_pkg = thisPackage dflags + -- + case maybe_pkg of + Just pkg | fsToPackageId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do + res <- findImportedModule hsc_env mod_name maybe_pkg + case res of + Found _ m -> return m + err -> noModError dflags noSrcSpan mod_name err + _otherwise -> do + home <- lookupLoadedHomeModule mod_name + case home of + Just m -> return m + Nothing -> liftIO $ do + res <- findImportedModule hsc_env mod_name maybe_pkg + case res of + Found loc m | modulePackageId m /= this_pkg -> return m + | otherwise -> modNotLoadedError m loc + err -> noModError dflags noSrcSpan mod_name err + +modNotLoadedError :: Module -> ModLocation -> IO a +modNotLoadedError m loc = ghcError $ CmdLineError $ showSDoc $ + text "module is not loaded:" <+> + quotes (ppr (moduleName m)) <+> + parens (text (expectJust "modNotLoadedError" (ml_hs_file loc))) + +-- | Like 'findModule', but differs slightly when the module refers to +-- a source file, and the file has not been loaded via 'load'. In +-- this case, 'findModule' will throw an error (module not loaded), +-- but 'lookupModule' will check to see whether the module can also be +-- found in a package, and if so, that package 'Module' will be +-- returned. If not, the usual module-not-found error will be thrown. +-- +lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module +lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg) +lookupModule mod_name Nothing = withSession $ \hsc_env -> do + home <- lookupLoadedHomeModule mod_name + case home of + Just m -> return m + Nothing -> liftIO $ do + res <- findExposedPackageModule hsc_env mod_name Nothing + case res of + Found _ m -> return m + err -> noModError (hsc_dflags hsc_env) noSrcSpan mod_name err + +lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module) +lookupLoadedHomeModule mod_name = withSession $ \hsc_env -> + case lookupUFM (hsc_HPT hsc_env) mod_name of + Just mod_info -> return (Just (mi_module (hm_iface mod_info))) + _not_a_home_module -> return Nothing #ifdef GHCI getHistorySpan :: GhcMonad m => History -> m SrcSpan