X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=5dfa76c8d41c9d94c3860738c7dcc529a010039a;hb=9eba9078e1993db58b8e12e9287f448df64a4fb6;hp=72806cbf94daf1ff280fc37f049990d237be3c06;hpb=21c190f4ace4e12304a17c8169b75213fb6ea1b4;p=ghc-hetmet.git diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 72806cb..5dfa76c 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, @@ -100,7 +98,7 @@ module GHC ( typeKind, parseName, RunResult(..), - runStmt, SingleStep(..), + runStmt, parseImportDecl, SingleStep(..), resume, Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan, resumeHistory, resumeHistoryIx), @@ -113,13 +111,13 @@ module GHC ( showModule, isModuleInterpreted, InteractiveEval.compileExpr, HValue, dynCompileExpr, - lookupName, GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType, modInfoModBreaks, ModBreaks(..), BreakIndex, BreakInfo(breakInfo_number, breakInfo_module), BreakArray, setBreakOn, setBreakOff, getBreak, #endif + lookupName, -- * Abstract syntax elements @@ -160,7 +158,7 @@ module GHC ( -- ** Data constructors DataCon, dataConSig, dataConType, dataConTyCon, dataConFieldLabels, - dataConIsInfix, isVanillaDataCon, + dataConIsInfix, isVanillaDataCon, dataConUserType, dataConStrictMarks, StrictnessMark(..), isMarkedStrict, @@ -178,7 +176,7 @@ module GHC ( pprParendType, pprTypeApp, Kind, PredType, - ThetaType, pprThetaArrow, + ThetaType, pprForAll, pprThetaArrow, -- ** Entities TyThing(..), @@ -244,11 +242,10 @@ import qualified Linker import Linker ( HValue ) import ByteCodeInstr import BreakArray -import NameSet import InteractiveEval -import TcRnDriver #endif +import TcRnDriver import TcIface import TcRnTypes hiding (LIE) import TcRnMonad ( initIfaceCheck ) @@ -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 @@ -287,8 +284,7 @@ import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept, cleanTempDirs ) import Annotations import Module -import LazyUniqFM -import qualified UniqFM as UFM +import UniqFM import FiniteMap import Panic import Digraph @@ -300,12 +296,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 @@ -341,6 +334,7 @@ defaultErrorHandler dflags inner = Just (ioe :: IOException) -> fatalErrorMsg dflags (text (show ioe)) _ -> case fromException exception of + Just UserInterrupt -> exitWith (ExitFailure 1) Just StackOverflow -> fatalErrorMsg dflags (text "stack overflow: use +RTS -K to increase it") _ -> case fromException exception of @@ -357,7 +351,7 @@ defaultErrorHandler dflags inner = hFlush stdout case ge of PhaseFailed _ code -> exitWith code - Interrupted -> exitWith (ExitFailure 1) + Signal _ -> exitWith (ExitFailure 1) _ -> do fatalErrorMsg dflags (text (show ge)) exitWith (ExitFailure 1) ) $ @@ -459,8 +453,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 @@ -626,15 +618,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 @@ -783,7 +766,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, @@ -887,7 +870,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) $ @@ -1035,7 +1018,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: @@ -1129,25 +1112,35 @@ 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 @@ -1207,7 +1200,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. @@ -1241,7 +1234,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 @@ -2023,7 +2016,10 @@ msDeps s = ++ [ (m,False) | m <- ms_home_imps s ] home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName] -home_imps imps = [ ideclName i | L _ i <- imps, isNothing (ideclPkgQual i) ] +home_imps imps = [ ideclName i | L _ i <- imps, isLocal (ideclPkgQual i) ] + where isLocal Nothing = True + isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special + isLocal _ = False ms_home_allimps :: ModSummary -> [ModuleName] ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms) @@ -2332,18 +2328,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) @@ -2429,7 +2435,7 @@ getPackageModuleInfo hsc_env mdl = do return (Just (ModuleInfo { minf_type_env = mkTypeEnv tys, minf_exports = names, - minf_rdr_env = Just $! nameSetToGlobalRdrEnv names (moduleName mdl), + minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails, minf_instances = error "getModuleInfo: instances for package module unimplemented", minf_modBreaks = emptyModBreaks })) @@ -2529,11 +2535,11 @@ packageDbModules :: GhcMonad m => -> m [Module] packageDbModules only_exposed = do dflags <- getSessionDynFlags - let pkgs = UFM.eltsUFM (pkgIdMap (pkgState dflags)) + let pkgs = eltsUFM (pkgIdMap (pkgState dflags)) return $ [ mkModule pid modname | p <- pkgs , not only_exposed || exposed p - , pid <- [mkPackageId (package p)] + , let pid = packageConfigId p , modname <- exposedModules p ] -- ----------------------------------------------------------------------------- @@ -2584,7 +2590,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 +2601,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 +2632,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 +2654,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 @@ -2682,3 +2723,12 @@ obtainTermFromId bound force id = liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id #endif + +-- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any +-- entity known to GHC, including 'Name's defined using 'runStmt'. +lookupName :: GhcMonad m => Name -> m (Maybe TyThing) +lookupName name = withSession $ \hsc_env -> do + mb_tything <- ioMsg $ tcRnLookupName hsc_env name + return mb_tything + -- XXX: calls panic in some circumstances; is that ok? +