X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=6cdce86759c0a7d059dea6a848c2df61b4fc7c17;hp=38208a0c693efb0b7b1ce38e45fb4983dff3f61e;hb=338cac018258e0c5540e18e0efe7dc84dfce8c86;hpb=421b380e75a04f4e1e8e110b46a4bf872e006f79 diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 38208a0..6cdce86 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -15,9 +15,10 @@ module GHC ( Ghc, GhcT, GhcMonad(..), runGhc, runGhcT, initGhcMonad, gcatch, gbracket, gfinally, - clearWarnings, getWarnings, hasWarnings, - printExceptionAndWarnings, printWarnings, + printException, + printExceptionAndWarnings, handleSourceError, + needsTemplateHaskell, -- * Flags and settings DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt, @@ -35,29 +36,22 @@ module GHC ( removeTarget, guessTarget, - -- * Extending the program scope - extendGlobalRdrScope, - setGlobalRdrScope, - extendGlobalTypeScope, - setGlobalTypeScope, - -- * Loading\/compiling the program depanal, - load, loadWithLogger, LoadHowMuch(..), SuccessFlag(..), -- also does depanal + load, LoadHowMuch(..), + SuccessFlag(..), succeeded, failed, defaultWarnErrLogger, WarnErrLogger, workingDirectoryChanged, parseModule, typecheckModule, desugarModule, loadModule, - ParsedModule, TypecheckedModule, DesugaredModule, -- all abstract + ParsedModule(..), TypecheckedModule(..), DesugaredModule(..), TypecheckedSource, ParsedSource, RenamedSource, -- ditto + TypecheckedMod, ParsedMod, moduleInfo, renamedSource, typecheckedSource, parsedSource, coreModule, compileToCoreModule, compileToCoreSimplified, compileCoreToObj, getModSummary, - -- * Parsing Haddock comments - parseHaddockComment, - -- * Inspecting the module structure of the program ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..), getModuleGraph, @@ -74,14 +68,19 @@ module GHC ( modInfoIsExportedName, modInfoLookupName, lookupGlobalName, + findGlobalAnns, mkPrintUnqualifiedForModule, + -- * Querying the environment + packageDbModules, + -- * Printing PrintUnqualified, alwaysQualify, -- * Interactive evaluation getBindings, getPrintUnqual, findModule, + lookupModule, #ifdef GHCI setContext, getContext, getNamesInScope, @@ -93,11 +92,11 @@ module GHC ( typeKind, parseName, RunResult(..), - runStmt, SingleStep(..), + runStmt, parseImportDecl, SingleStep(..), resume, Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan, resumeHistory, resumeHistoryIx), - History(historyBreakInfo, historyEnclosingDecl), + History(historyBreakInfo, historyEnclosingDecls), GHC.getHistorySpan, getHistoryModule, getResumeContext, abandon, abandonAll, @@ -106,13 +105,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 @@ -143,7 +142,7 @@ module GHC ( TyCon, tyConTyVars, tyConDataCons, tyConArity, isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon, - isOpenTyCon, + isFamilyTyCon, synTyConDefn, synTyConType, synTyConResKind, -- ** Type variables @@ -153,7 +152,7 @@ module GHC ( -- ** Data constructors DataCon, dataConSig, dataConType, dataConTyCon, dataConFieldLabels, - dataConIsInfix, isVanillaDataCon, + dataConIsInfix, isVanillaDataCon, dataConUserType, dataConStrictMarks, StrictnessMark(..), isMarkedStrict, @@ -171,7 +170,7 @@ module GHC ( pprParendType, pprTypeApp, Kind, PredType, - ThetaType, pprThetaArrow, + ThetaType, pprForAll, pprThetaArrow, -- ** Entities TyThing(..), @@ -196,6 +195,20 @@ module GHC ( srcSpanStartLine, srcSpanEndLine, srcSpanStartCol, srcSpanEndCol, + -- ** Located + Located(..), + + -- *** Constructing Located + noLoc, mkGeneralLocated, + + -- *** Deconstructing Located + getLoc, unLoc, + + -- *** Combining and comparing Located values + eqLocated, cmpLocated, combineLocs, addCLoc, + leftmost_smallest, leftmost_largest, rightmost, + spans, isSubspanOf, + -- * Exceptions GhcException(..), showGhcException, @@ -204,6 +217,9 @@ module GHC ( getTokenStream, getRichTokenStream, showRichTokenStream, addSourceToTokens, + -- * Pure interface to the parser + parser, + -- * Miscellaneous --sessionHscEnv, cyclicModuleErr, @@ -223,73 +239,72 @@ import qualified Linker import Linker ( HValue ) import ByteCodeInstr import BreakArray -import NameSet import InteractiveEval -import TcRnDriver #endif -import TcIface -import TcRnTypes hiding (LIE) +import HscMain +import DriverPipeline +import GhcMonad +import TcIface ( typecheckIface ) +import TcRnTypes import TcRnMonad ( initIfaceCheck ) import Packages 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 Coercion ( synTyConResKind ) +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 InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr, - emptyInstEnv ) -import FamInstEnv ( emptyFamInstEnv ) +-- import OccName ( parenSymOcc ) +import InstEnv import SrcLoc ---import CoreSyn +import CoreSyn ( CoreBind ) import TidyPgm -import DriverPipeline -import DriverPhases ( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase ) +import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase ) import HeaderInfo import Finder -import HscMain import HscTypes import DynFlags import StaticFlagParser import qualified StaticFlags import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept, cleanTempDirs ) +import Annotations import Module -import LazyUniqFM -import UniqSet -import Unique -import FiniteMap +import UniqFM import Panic import Digraph -import Bag ( unitBag, listToBag, emptyBag, isEmptyBag ) +import Bag ( unitBag, listToBag ) import ErrUtils import MonadUtils import Util -import StringBuffer ( StringBuffer, hGetStringBuffer, nextChar ) +import StringBuffer import Outputable import BasicTypes import Maybes ( expectJust, mapCatMaybes ) -import HaddockParse -import HaddockLex ( tokenise ) import FastString +import qualified Parser import Lexer -import Control.Concurrent import System.Directory ( getModificationTime, doesFileExist, getCurrentDirectory ) import Data.Maybe +import Data.Map (Map) +import qualified Data.Map as Map +import qualified FiniteMap as Map import Data.List import qualified Data.List as List +import Data.Typeable ( Typeable ) +import Data.Word ( Word8 ) import Control.Monad import System.Exit ( exitWith, ExitCode(..) ) import System.Time ( ClockTime, getClockTime ) @@ -297,7 +312,7 @@ import Exception import Data.IORef import System.FilePath import System.IO -import System.IO.Error ( try, isDoesNotExistError ) +import System.IO.Error ( isDoesNotExistError ) import Prelude hiding (init) @@ -318,6 +333,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 @@ -328,20 +344,13 @@ defaultErrorHandler dflags inner = exitWith (ExitFailure 1) ) $ - -- program errors: messages with locations attached. Sometimes it is - -- convenient to just throw these as exceptions. - handleErrMsg - (\em -> liftIO $ do - printBagOfErrors dflags (unitBag em) - exitWith (ExitFailure 1)) $ - -- error messages propagated as exceptions handleGhcException (\ge -> liftIO $ do 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) ) $ @@ -355,7 +364,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 @@ -366,28 +375,14 @@ defaultCleanupHandler dflags inner = -- | Print the error message and all warnings. Useful inside exception -- handlers. Clears warnings after printing. +printException :: GhcMonad m => SourceError -> m () +printException err = do + dflags <- getSessionDynFlags + liftIO $ printBagOfErrors dflags (srcErrorMessages err) + +{-# DEPRECATED printExceptionAndWarnings "use printException instead" #-} printExceptionAndWarnings :: GhcMonad m => SourceError -> m () -printExceptionAndWarnings err = do - let errs = srcErrorMessages err - warns <- getWarnings - dflags <- getSessionDynFlags - if isEmptyBag errs - -- Empty errors means we failed due to -Werror. (Since this function - -- takes a source error as argument, we know for sure _some_ error - -- did indeed happen.) - then liftIO $ do - printBagOfWarnings dflags warns - printBagOfErrors dflags (unitBag warnIsErrorMsg) - else liftIO $ printBagOfErrors dflags errs - clearWarnings - --- | Print all accumulated warnings using 'log_action'. -printWarnings :: GhcMonad m => m () -printWarnings = do - dflags <- getSessionDynFlags - warns <- getWarnings - liftIO $ printBagOfWarnings dflags warns - clearWarnings +printExceptionAndWarnings = printException -- | Run function for the 'Ghc' monad. -- @@ -402,9 +397,8 @@ runGhc :: Maybe FilePath -- ^ See argument to 'initGhcMonad'. -> Ghc a -- ^ The action to perform. -> IO a runGhc mb_top_dir ghc = do - wref <- newIORef emptyBag ref <- newIORef undefined - let session = Session ref wref + let session = Session ref flip unGhc session $ do initGhcMonad mb_top_dir ghc @@ -421,9 +415,8 @@ runGhcT :: (ExceptionMonad m, Functor m, MonadIO m) => -> GhcT m a -- ^ The action to perform. -> m a runGhcT mb_top_dir ghct = do - wref <- liftIO $ newIORef emptyBag ref <- liftIO $ newIORef undefined - let session = Session ref wref + let session = Session ref flip unGhcT session $ do initGhcMonad mb_top_dir ghct @@ -443,8 +436,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 @@ -453,15 +444,10 @@ initGhcMonad mb_top_dir = do dflags <- liftIO $ initSysTools mb_top_dir dflags0 env <- liftIO $ newHscEnv dflags setSession env - clearWarnings -- ----------------------------------------------------------------------------- -- Flags & settings --- | Grabs the DynFlags from the Session -getSessionDynFlags :: GhcMonad m => m DynFlags -getSessionDynFlags = withSession (return . hsc_dflags) - -- | Updates the DynFlags in a Session. This also reads -- the package database (unless it has already been read), -- and prepares the compilers knowledge about packages. It @@ -578,44 +564,20 @@ guessTarget str Nothing target tid = Target tid obj_allowed Nothing -- ----------------------------------------------------------------------------- --- Extending the program scope - -extendGlobalRdrScope :: GhcMonad m => [GlobalRdrElt] -> m () -extendGlobalRdrScope rdrElts - = modifySession $ \hscEnv -> - let global_rdr = hsc_global_rdr_env hscEnv - in hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv global_rdr rdrElts } - -setGlobalRdrScope :: GhcMonad m => [GlobalRdrElt] -> m () -setGlobalRdrScope rdrElts - = modifySession $ \hscEnv -> - hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv emptyGlobalRdrEnv rdrElts } - -extendGlobalTypeScope :: GhcMonad m => [Id] -> m () -extendGlobalTypeScope ids - = modifySession $ \hscEnv -> - let global_type = hsc_global_type_env hscEnv - in hscEnv{ hsc_global_type_env = extendTypeEnvWithIds global_type ids } - -setGlobalTypeScope :: GhcMonad m => [Id] -> m () -setGlobalTypeScope ids - = modifySession $ \hscEnv -> - 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 -- and update the session with the new module graph. +-- +-- Dependency analysis entails parsing the @import@ directives and may +-- therefore require running certain preprocessors. +-- +-- Note that each 'ModSummary' in the module graph caches its 'DynFlags'. +-- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the +-- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want to +-- changes to the 'DynFlags' to take effect you need to call this function +-- again. +-- depanal :: GhcMonad m => [ModuleName] -- ^ excluded modules -> Bool -- ^ allow duplicate roots @@ -632,47 +594,49 @@ depanal excluded_mods allow_dup_roots = do text "Chasing modules from: ", hcat (punctuate comma (map pprTarget targets))]) - mod_graph <- downsweep hsc_env old_graph excluded_mods allow_dup_roots + mod_graph <- liftIO $ downsweep hsc_env old_graph excluded_mods allow_dup_roots modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph } return mod_graph +-- | Describes which modules of the module graph need to be loaded. data LoadHowMuch = LoadAllTargets + -- ^ Load all targets and its dependencies. | LoadUpTo ModuleName + -- ^ Load only the given module and its dependencies. | LoadDependenciesOf ModuleName + -- ^ Load only the dependencies of the given module, but not the module + -- itself. --- | Try to load the program. Calls 'loadWithLogger' with the default --- compiler that just immediately logs all warnings and errors. +-- | Try to load the program. See 'LoadHowMuch' for the different modes. +-- +-- This function implements the core of GHC's @--make@ mode. It preprocesses, +-- compiles and loads the specified modules, avoiding re-compilation wherever +-- possible. Depending on the target (see 'DynFlags.hscTarget') compilating +-- and loading may result in files being created on disk. +-- +-- Calls the 'reportModuleCompilationResult' callback after each compiling +-- each module, whether successful or not. +-- +-- Throw a 'SourceError' if errors are encountered before the actual +-- compilation starts (e.g., during dependency analysis). All other errors +-- are reported using the callback. +-- load :: GhcMonad m => LoadHowMuch -> m SuccessFlag -load how_much = - loadWithLogger defaultWarnErrLogger how_much +load how_much = do + mod_graph <- depanal [] False + load2 how_much mod_graph -- | A function called to log warnings and errors. type WarnErrLogger = GhcMonad m => Maybe SourceError -> m () defaultWarnErrLogger :: WarnErrLogger -defaultWarnErrLogger Nothing = printWarnings -defaultWarnErrLogger (Just e) = printExceptionAndWarnings e +defaultWarnErrLogger Nothing = return () +defaultWarnErrLogger (Just e) = printException e --- | Try to load the program. If a Module is supplied, then just --- attempt to load up to this target. If no Module is supplied, --- then try to load all targets. --- --- The first argument is a function that is called after compiling each --- module to print wanrings and errors. - -loadWithLogger :: GhcMonad m => WarnErrLogger -> LoadHowMuch -> m SuccessFlag -loadWithLogger logger 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 - -- graph is still retained in the Session. We can tell which modules - -- were successfully loaded by inspecting the Session's HPT. - mod_graph <- depanal [] False - load2 how_much mod_graph logger - -load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] -> WarnErrLogger +load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] -> m SuccessFlag -load2 how_much mod_graph logger = do +load2 how_much mod_graph = do guessOutputFile hsc_env <- getSession @@ -714,7 +678,7 @@ load2 how_much mod_graph logger = do -- If we can determine that any of the {-# SOURCE #-} imports -- are definitely unnecessary, then emit a warning. - warnUnnecessarySourceImports dflags mg2_with_srcimps + warnUnnecessarySourceImports mg2_with_srcimps let -- check the stability property for each module. @@ -727,7 +691,7 @@ load2 how_much mod_graph logger = 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, @@ -798,10 +762,10 @@ load2 how_much mod_graph logger = do liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") 2 (ppr mg)) - (upsweep_ok, hsc_env1, modsUpswept) - <- upsweep logger - (hsc_env { hsc_HPT = emptyHomePackageTable }) - pruned_hpt stable_mods cleanup mg + + setSession hsc_env{ hsc_HPT = emptyHomePackageTable } + (upsweep_ok, modsUpswept) + <- upsweep pruned_hpt stable_mods cleanup mg -- Make modsDone be the summaries for each home module now -- available; this should equal the domain of hpt3. @@ -832,7 +796,7 @@ load2 how_much mod_graph logger = 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) $ @@ -843,9 +807,10 @@ load2 how_much mod_graph logger = do moduleNameString (moduleName main_mod) ++ " module.") -- link everything together + hsc_env1 <- getSession linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) - loadFinish Succeeded linkresult hsc_env1 + loadFinish Succeeded linkresult else -- Tricky. We need to back out the effects of compiling any @@ -862,6 +827,7 @@ load2 how_much mod_graph logger = do = filter ((`notElem` mods_to_zap_names).ms_mod) modsDone + hsc_env1 <- getSession let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) (hsc_HPT hsc_env1) @@ -875,24 +841,25 @@ load2 how_much mod_graph logger = do -- Link everything together linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4 - let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 } - loadFinish Failed linkresult hsc_env4 + modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 } + loadFinish Failed linkresult -- Finish up after a load. -- If the link failed, unload everything and return. loadFinish :: GhcMonad m => - SuccessFlag -> SuccessFlag -> HscEnv + SuccessFlag -> SuccessFlag -> m SuccessFlag -loadFinish _all_ok Failed hsc_env - = do liftIO $ unload hsc_env [] - modifySession $ \_ -> discardProg hsc_env +loadFinish _all_ok Failed + = do hsc_env <- getSession + liftIO $ unload hsc_env [] + modifySession discardProg return Failed -- Empty the interactive context and set the module context to the topmost -- newly loaded module, or the Prelude if none were loaded. -loadFinish all_ok Succeeded hsc_env - = do modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext } +loadFinish all_ok Succeeded + = do modifySession $ \hsc_env -> hsc_env{ hsc_IC = emptyInteractiveContext } return all_ok @@ -980,7 +947,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: @@ -1016,9 +983,9 @@ getModSummary mod = do -- Throws a 'SourceError' on parse error. parseModule :: GhcMonad m => ModSummary -> m ParsedModule parseModule ms = do - hsc_env0 <- getSession - let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms } - rdr_module <- parseFile hsc_env ms + hsc_env <- getSession + let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } + rdr_module <- liftIO $ hscParse hsc_env_tmp ms return (ParsedModule ms rdr_module) -- | Typecheck and rename a parsed module. @@ -1026,13 +993,13 @@ parseModule ms = do -- Throws a 'SourceError' if either fails. typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule typecheckModule pmod = do - let ms = modSummary pmod - hsc_env0 <- getSession - let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms } - (tc_gbl_env, rn_info) - <- typecheckRenameModule hsc_env ms (parsedSource pmod) - details <- liftIO $ makeSimpleDetails hsc_env tc_gbl_env - return $ + let ms = modSummary pmod + hsc_env <- getSession + let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } + (tc_gbl_env, rn_info) + <- liftIO $ hscTypecheckRename hsc_env_tmp ms (parsedSource pmod) + details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env + return $ TypecheckedModule { tm_internals_ = (tc_gbl_env, details), tm_parsed_module = pmod, @@ -1052,12 +1019,12 @@ typecheckModule pmod = do -- | Desugar a typechecked module. desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule desugarModule tcm = do - let ms = modSummary tcm - hsc_env0 <- getSession - let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms } - let (tcg, _) = tm_internals tcm - guts <- deSugarModule hsc_env ms tcg - return $ + let ms = modSummary tcm + let (tcg, _) = tm_internals tcm + hsc_env <- getSession + let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } + guts <- liftIO $ hscDesugar hsc_env_tmp ms tcg + return $ DesugaredModule { dm_typechecked_module = tcm, dm_core_module = guts @@ -1065,23 +1032,58 @@ 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 - hsc_env0 <- getSession - let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms } - let (tcg, details) = tm_internals tcm - (iface,_) <- liftIO $ makeSimpleIface hsc_env Nothing tcg details - let mod_info = HomeModInfo { - hm_iface = iface, - hm_details = details, - hm_linkable = Nothing } - let hpt_new = addToUFM (hsc_HPT hsc_env) mod mod_info - modifySession $ \_ -> hsc_env0{ hsc_HPT = hpt_new } + let loc = ms_location ms + let (tcg, _details) = tm_internals tcm + + 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 doesn't change the session + hsc_env <- getSession + mod_info <- liftIO $ compile' (hscNothingBackendOnly tcg, + hscInteractiveBackendOnly tcg, + hscBatchBackendOnly tcg) + hsc_env ms 1 1 Nothing mb_linkable + + modifySession $ \e -> e{ hsc_HPT = addToUFM (hsc_HPT e) mod mod_info } return tcm +-- ----------------------------------------------------------------------------- +-- Operations dealing with Core + +-- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for +-- the 'GHC.compileToCoreModule' interface. +data CoreModule + = CoreModule { + -- | Module name + cm_module :: !Module, + -- | Type environment for types declared in this module + cm_types :: !TypeEnv, + -- | Declarations + cm_binds :: [CoreBind], + -- | Imports + cm_imports :: ![Module] + } + +instance Outputable CoreModule where + ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb}) = + text "%module" <+> ppr mn <+> ppr te $$ vcat (map ppr cb) + -- | 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 @@ -1108,11 +1110,9 @@ compileToCore fn = do -- 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 :: GhcMonad m => Bool -> CoreModule -> m () compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do - hscEnv <- getSession dflags <- getSessionDynFlags currentTime <- liftIO $ getClockTime cwd <- liftIO $ getCurrentDirectory @@ -1137,48 +1137,16 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do ms_hspp_buf = Nothing } - ioMsgMaybe $ flip evalComp (CompState{ compHscEnv=hscEnv, - compModSummary=modSummary, - compOldIface=Nothing}) $ - let maybe_simplify mod_guts | simplify = hscSimplify mod_guts - | otherwise = return mod_guts - in maybe_simplify (mkModGuts cm) - >>= hscNormalIface - >>= hscWriteIface - >>= hscOneShot - return () - --- 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 -} + hsc_env <- getSession + liftIO $ hscCompileCore hsc_env simplify modSummary (cm_binds cm) + compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule 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 @@ -1186,6 +1154,7 @@ compileCore simplify fn = do -- Now we have the module name; -- parse, typecheck and desugar the module mod_guts <- coreModule `fmap` + -- TODO: space leaky: call hsc* directly? (desugarModule =<< typecheckModule =<< parseModule modSummary) liftM gutsToCoreModule $ if simplify @@ -1193,11 +1162,7 @@ compileCore simplify fn = do -- If simplify is true: simplify (hscSimplify), then tidy -- (tidyProgram). hsc_env <- getSession - simpl_guts <- ioMsg $ evalComp (hscSimplify mod_guts) - (CompState{ - compHscEnv = hsc_env, - compModSummary = modSummary, - compOldIface = Nothing}) + simpl_guts <- liftIO $ hscSimplify hsc_env mod_guts tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts return $ Left tidy_guts else @@ -1302,7 +1267,7 @@ checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs scc_mods = map ms_mod_name scc home_module m = m `elem` all_home_mods && m `notElem` scc_mods - scc_allimps = nub (filter home_module (concatMap ms_allimps scc)) + scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc)) -- all imports outside the current SCC, but in the home pkg stable_obj_imps = map (`elem` stable_obj) scc_allimps @@ -1339,9 +1304,6 @@ checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs linkableTime l >= ms_hs_date ms _other -> False -ms_allimps :: ModSummary -> [ModuleName] -ms_allimps ms = map unLoc (ms_srcimps ms ++ ms_imps ms) - -- ----------------------------------------------------------------------------- -- | Prune the HomePackageTable @@ -1413,49 +1375,54 @@ findPartiallyCompletedCycles modsDone theGraph -- There better had not be any cyclic groups here -- we check for them. upsweep - :: GhcMonad m => - WarnErrLogger -- ^ Called to print warnings and errors. - -> HscEnv -- ^ Includes initially-empty HPT - -> HomePackageTable -- ^ HPT from last time round (pruned) + :: GhcMonad m + => HomePackageTable -- ^ HPT from last time round (pruned) -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability) -> IO () -- ^ How to clean up unwanted tmp files -> [SCC ModSummary] -- ^ Mods to do (the worklist) -> m (SuccessFlag, - HscEnv, -- With an updated HPT - [ModSummary]) -- Mods which succeeded - -upsweep logger hsc_env old_hpt stable_mods cleanup sccs = do - (res, hsc_env, done) <- upsweep' hsc_env old_hpt [] sccs 1 (length sccs) - return (res, hsc_env, reverse done) + [ModSummary]) + -- ^ Returns: + -- + -- 1. A flag whether the complete upsweep was successful. + -- 2. The 'HscEnv' in the monad has an updated HPT + -- 3. A list of modules which succeeded loading. + +upsweep old_hpt stable_mods cleanup sccs = do + (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs) + return (res, reverse done) where - upsweep' hsc_env _old_hpt done + upsweep' _old_hpt done [] _ _ - = return (Succeeded, hsc_env, done) + = return (Succeeded, done) - upsweep' hsc_env _old_hpt done + upsweep' _old_hpt done (CyclicSCC ms:_) _ _ - = do liftIO $ fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms) - return (Failed, hsc_env, done) + = do dflags <- getSessionDynFlags + liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms) + return (Failed, done) - upsweep' hsc_env old_hpt done + upsweep' old_hpt done (AcyclicSCC mod:mods) mod_index nmods = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ -- show (map (moduleUserString.moduleName.mi_module.hm_iface) -- (moduleEnvElts (hsc_HPT hsc_env))) + let logger _mod = defaultWarnErrLogger + hsc_env <- getSession mb_mod_info <- handleSourceError - (\err -> do logger (Just err); return Nothing) $ do - mod_info <- upsweep_mod hsc_env old_hpt stable_mods - mod mod_index nmods - logger Nothing -- log warnings + (\err -> do logger mod (Just err); return Nothing) $ do + mod_info <- liftIO $ upsweep_mod hsc_env old_hpt stable_mods + mod mod_index nmods + logger mod Nothing -- log warnings return (Just mod_info) liftIO cleanup -- Remove unwanted tmp files between compilations case mb_mod_info of - Nothing -> return (Failed, hsc_env, done) + Nothing -> return (Failed, done) Just mod_info -> do let this_mod = ms_mod_name mod @@ -1478,19 +1445,19 @@ upsweep logger hsc_env old_hpt stable_mods cleanup sccs = do -- fixup our HomePackageTable after we've finished compiling -- a mutually-recursive loop. See reTypecheckLoop, below. hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done' + setSession hsc_env2 - upsweep' hsc_env2 old_hpt1 done' mods (mod_index+1) nmods + upsweep' old_hpt1 done' mods (mod_index+1) nmods -- | Compile a single module. Always produce a Linkable for it if -- successful. If no compilation happened, return the old Linkable. -upsweep_mod :: GhcMonad m => - HscEnv +upsweep_mod :: HscEnv -> HomePackageTable -> ([ModuleName],[ModuleName]) -> ModSummary -> Int -- index of module -> Int -- total number of modules - -> m HomeModInfo + -> IO HomeModInfo upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods = let @@ -1542,74 +1509,101 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods where iface = hm_iface hm_info - compile_it :: GhcMonad m => Maybe Linkable -> m HomeModInfo - compile_it = compile hsc_env summary' mod_index nmods mb_old_iface - - compile_it_discard_iface :: GhcMonad m => - Maybe Linkable -> m HomeModInfo - compile_it_discard_iface - = compile hsc_env summary' mod_index nmods Nothing + compile_it :: Maybe Linkable -> IO HomeModInfo + compile_it mb_linkable = + compile hsc_env summary' mod_index nmods + mb_old_iface mb_linkable + + compile_it_discard_iface :: Maybe Linkable -> IO HomeModInfo + compile_it_discard_iface mb_linkable = + compile hsc_env summary' mod_index nmods + Nothing mb_linkable + + -- With the HscNothing target we create empty linkables to avoid + -- recompilation. We have to detect these to recompile anyway if + -- the target changed since the last compile. + is_fake_linkable + | Just hmi <- old_hmi, Just l <- hm_linkable hmi = + null (linkableUnlinked l) + | otherwise = + -- we have no linkable, so it cannot be fake + False + + implies False _ = True + implies True x = x in - case target of - - _any + case () of + _ -- Regardless of whether we're generating object code or -- byte code, we can always use an existing object file -- if it is *stable* (see checkStability). - | is_stable_obj, isJust old_hmi -> - let Just hmi = old_hmi in - return hmi - -- object is stable, and we have an entry in the - -- old HPT: nothing to do - - | is_stable_obj, isNothing old_hmi -> do - linkable <- liftIO $ findObjectLinkable this_mod obj_fn - (expectJust "upsweep1" mb_obj_date) - compile_it (Just linkable) - -- object is stable, but we need to load the interface - -- off disk to make a HMI. - - HscInterpreted - | is_stable_bco -> - ASSERT(isJust old_hmi) -- must be in the old_hpt - let Just hmi = old_hmi in - return hmi - -- BCO is stable: nothing to do - - | Just hmi <- old_hmi, - Just l <- hm_linkable hmi, not (isObjectLinkable l), - linkableTime l >= ms_hs_date summary -> - compile_it (Just l) - -- we have an old BCO that is up to date with respect - -- to the source: do a recompilation check as normal. - - | otherwise -> - compile_it Nothing - -- no existing code at all: we must recompile. - - -- When generating object code, if there's an up-to-date - -- object file on the disk, then we can use it. - -- However, if the object file is new (compared to any - -- linkable we had from a previous compilation), then we - -- must discard any in-memory interface, because this - -- means the user has compiled the source file - -- separately and generated a new interface, that we must - -- read from the disk. - -- - obj | isObjectTarget obj, - Just obj_date <- mb_obj_date, obj_date >= hs_date -> do - case old_hmi of - Just hmi - | Just l <- hm_linkable hmi, - isObjectLinkable l && linkableTime l == obj_date - -> compile_it (Just l) - _otherwise -> do - linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date + | is_stable_obj, Just hmi <- old_hmi -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "skipping stable obj mod:" <+> ppr this_mod_name) + return hmi + -- object is stable, and we have an entry in the + -- old HPT: nothing to do + + | is_stable_obj, isNothing old_hmi -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling stable on-disk mod:" <+> ppr this_mod_name) + linkable <- liftIO $ findObjectLinkable this_mod obj_fn + (expectJust "upsweep1" mb_obj_date) + compile_it (Just linkable) + -- object is stable, but we need to load the interface + -- off disk to make a HMI. + + | not (isObjectTarget target), is_stable_bco, + (target /= HscNothing) `implies` not is_fake_linkable -> + ASSERT(isJust old_hmi) -- must be in the old_hpt + let Just hmi = old_hmi in do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "skipping stable BCO mod:" <+> ppr this_mod_name) + return hmi + -- BCO is stable: nothing to do + + | not (isObjectTarget target), + Just hmi <- old_hmi, + Just l <- hm_linkable hmi, + not (isObjectLinkable l), + (target /= HscNothing) `implies` not is_fake_linkable, + linkableTime l >= ms_hs_date summary -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling non-stable BCO mod:" <+> ppr this_mod_name) + compile_it (Just l) + -- we have an old BCO that is up to date with respect + -- to the source: do a recompilation check as normal. + + -- When generating object code, if there's an up-to-date + -- object file on the disk, then we can use it. + -- However, if the object file is new (compared to any + -- linkable we had from a previous compilation), then we + -- must discard any in-memory interface, because this + -- means the user has compiled the source file + -- separately and generated a new interface, that we must + -- read from the disk. + -- + | isObjectTarget target, + Just obj_date <- mb_obj_date, + obj_date >= hs_date -> do + case old_hmi of + Just hmi + | Just l <- hm_linkable hmi, + isObjectLinkable l && linkableTime l == obj_date -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name) + compile_it (Just l) + _otherwise -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name) + linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date compile_it_discard_iface (Just linkable) - _otherwise -> - compile_it Nothing + _otherwise -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod:" <+> ppr this_mod_name) + compile_it Nothing @@ -1696,11 +1690,13 @@ reachableBackwards mod summaries type SummaryNode = (ModSummary, Int, [Int]) topSortModuleGraph - :: Bool -- Drop hi-boot nodes? (see below) + :: Bool + -- ^ Drop hi-boot nodes? (see below) -> [ModSummary] -> Maybe ModuleName + -- ^ Root module name. If @Nothing@, use the full graph. -> [SCC ModSummary] --- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes +-- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes -- The resulting list of strongly-connected-components is in topologically -- sorted order, starting with the module(s) at the bottom of the -- dependency graph (ie compile them first) and ending with the ones at @@ -1708,10 +1704,10 @@ topSortModuleGraph -- -- Drop hi-boot nodes (first boolean arg)? -- --- False: treat the hi-boot summaries as nodes of the graph, +-- - @False@: treat the hi-boot summaries as nodes of the graph, -- so the graph must be acyclic -- --- True: eliminate the hi-boot nodes, and instead pretend +-- - @True@: eliminate the hi-boot nodes, and instead pretend -- the a source-import of Foo is an import of Foo -- The resulting graph has no hi-boot nodes, but can be cyclic @@ -1744,14 +1740,14 @@ moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, l numbered_summaries = zip summaries [1..] lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode - lookup_node hs_src mod = lookupFM node_map (mod, hs_src) + lookup_node hs_src mod = Map.lookup (mod, hs_src) node_map 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 ] + node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node) + | node@(s, _, _) <- nodes ] -- We use integers as the keys for the SCC algorithm nodes :: [SummaryNode] @@ -1759,8 +1755,8 @@ moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, l | (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)) ++ + , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++ + out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++ (-- see [boot-edges] below if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile then [] @@ -1787,28 +1783,28 @@ moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, l type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are -type NodeMap a = FiniteMap NodeKey a -- keyed by (mod, src_file_type) pairs +type NodeMap a = Map NodeKey a -- keyed by (mod, src_file_type) pairs msKey :: ModSummary -> NodeKey msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot) mkNodeMap :: [ModSummary] -> NodeMap ModSummary -mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries] +mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries] nodeMapElts :: NodeMap a -> [a] -nodeMapElts = eltsFM +nodeMapElts = Map.elems -- | If there are {-# SOURCE #-} imports between strongly connected -- components in the topological sort, then those imports can -- definitely be replaced by ordinary non-SOURCE imports: if SOURCE -- were necessary, then the edge would be part of a cycle. -warnUnnecessarySourceImports :: GhcMonad m => DynFlags -> [SCC ModSummary] -> m () -warnUnnecessarySourceImports dflags sccs = - liftIO $ printBagOfWarnings dflags (listToBag (concatMap (check.flattenSCC) sccs)) +warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m () +warnUnnecessarySourceImports sccs = do + logWarnings (listToBag (concatMap (check.flattenSCC) sccs)) where check ms = let mods_in_this_cycle = map ms_mod_name ms in - [ warn i | m <- ms, i <- ms_srcimps m, - unLoc i `notElem` mods_in_this_cycle ] + [ warn i | m <- ms, i <- ms_home_srcimps m, + unLoc i `notElem` mods_in_this_cycle ] warn :: Located ModuleName -> WarnMsg warn (L loc mod) = @@ -1831,22 +1827,19 @@ warnUnnecessarySourceImports dflags sccs = -- module, plus one for any hs-boot files. The imports of these nodes -- are all there, including the imports of non-home-package modules. -downsweep :: GhcMonad m => - HscEnv +downsweep :: HscEnv -> [ModSummary] -- Old summaries -> [ModuleName] -- Ignore dependencies on these; treat -- them as if they were package modules -> Bool -- True <=> allow multiple targets to have -- the same module name; this is -- very useful for ghc -M - -> m [ModSummary] + -> IO [ModSummary] -- The elts of [ModSummary] all have distinct -- (Modules, IsBoot) identifiers, unless the Bool is true -- in which case there can be repeats downsweep hsc_env old_summaries excl_mods allow_dup_roots - = do -- catch error messages and return them - --handleErrMsg -- should be covered by GhcMonad now - -- (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do + = do rootSummaries <- mapM getRootSummary roots let root_map = mkRootMap rootSummaries checkDuplicates root_map @@ -1858,13 +1851,13 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots old_summary_map :: NodeMap ModSummary old_summary_map = mkNodeMap old_summaries - getRootSummary :: GhcMonad m => Target -> m ModSummary + getRootSummary :: Target -> IO ModSummary getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf) = do exists <- liftIO $ doesFileExist file if exists then summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf - else throwErrMsg $ mkPlainErrMsg noSrcSpan $ + else throwOneError $ mkPlainErrMsg noSrcSpan $ text "can't find file:" <+> text file getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) = do maybe_summary <- summariseModule hsc_env old_summary_map False @@ -1880,7 +1873,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots -- name, so we have to check that there aren't multiple root files -- defining the same module (otherwise the duplicates will be silently -- ignored, leading to confusing behaviour). - checkDuplicates :: GhcMonad m => NodeMap [ModSummary] -> m () + checkDuplicates :: NodeMap [ModSummary] -> IO () checkDuplicates root_map | allow_dup_roots = return () | null dup_roots = return () @@ -1889,36 +1882,37 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots dup_roots :: [[ModSummary]] -- Each at least of length 2 dup_roots = filterOut isSingleton (nodeMapElts root_map) - loop :: GhcMonad m => - [(Located ModuleName,IsBootInterface)] + loop :: [(Located ModuleName,IsBootInterface)] -- Work list: process these modules -> NodeMap [ModSummary] -- Visited set; the range is a list because -- the roots can have the same module names -- if allow_dup_roots is True - -> m [ModSummary] + -> IO [ModSummary] -- The result includes the worklist, except -- for those mentioned in the visited set loop [] done = return (concat (nodeMapElts done)) loop ((wanted_mod, is_boot) : ss) done - | Just summs <- lookupFM done key + | Just summs <- Map.lookup key done = if isSingleton summs then loop ss done else - do { liftIO $ multiRootsErr summs; return [] } + do { multiRootsErr summs; return [] } | 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]) + Just s -> loop (msDeps s ++ ss) (Map.insert key [s] done) where key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile) +-- XXX Does the (++) here need to be flipped? mkRootMap :: [ModSummary] -> NodeMap [ModSummary] -mkRootMap summaries = addListToFM_C (++) emptyFM - [ (msKey s, [s]) | s <- summaries ] +mkRootMap summaries = Map.insertListWith (flip (++)) + [ (msKey s, [s]) | s <- summaries ] + Map.empty msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)] -- (msDeps s) returns the dependencies of the ModSummary s. @@ -1930,8 +1924,23 @@ msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)] -- Remember, this pass isn't doing the topological sort. It's -- just gathering the list of all relevant ModSummaries msDeps s = - concat [ [(m,True), (m,False)] | m <- ms_srcimps s ] - ++ [ (m,False) | m <- ms_imps s ] + concat [ [(m,True), (m,False)] | m <- ms_home_srcimps s ] + ++ [ (m,False) | m <- ms_home_imps s ] + +home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName] +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) + +ms_home_srcimps :: ModSummary -> [Located ModuleName] +ms_home_srcimps = home_imps . ms_srcimps + +ms_home_imps :: ModSummary -> [Located ModuleName] +ms_home_imps = home_imps . ms_imps ----------------------------------------------------------------------------- -- Summarising modules @@ -1947,14 +1956,13 @@ msDeps s = -- resides. summariseFile - :: GhcMonad m => - HscEnv + :: HscEnv -> [ModSummary] -- old summaries -> FilePath -- source file name -> Maybe Phase -- start phase -> Bool -- object code allowed? -> Maybe (StringBuffer,ClockTime) - -> m ModSummary + -> IO ModSummary summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf -- we can use a cached summary if one is available and the @@ -1993,7 +2001,7 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf (dflags', hspp_fn, buf) <- preprocessFile hsc_env file mb_phase maybe_buf - (srcimps,the_imps, L _ mod_name) <- liftIO $ getImports dflags' buf hspp_fn file + (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file -- Make a ModLocation for this file location <- liftIO $ mkHomeModLocation dflags mod_name file @@ -2033,22 +2041,21 @@ findSummaryBySourceFile summaries file -- Summarise a module, and pick up source and timestamp. summariseModule - :: GhcMonad m => - HscEnv + :: HscEnv -> 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 - -> m (Maybe ModSummary) -- Its new summary + -> IO (Maybe ModSummary) -- Its new summary 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 - | Just old_summary <- lookupFM old_summary_map (wanted_mod, hsc_src) + | Just old_summary <- Map.lookup (wanted_mod, hsc_src) old_summary_map = do -- Find its new timestamp; all the -- ModSummaries in the old map have valid ml_hs_files let location = ms_location old_summary @@ -2060,11 +2067,11 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) case maybe_buf of Just (_,t) -> check_timestamp old_summary location src_fn t Nothing -> do - m <- liftIO $ System.IO.Error.try (getModificationTime src_fn) + m <- tryIO (getModificationTime src_fn) case m of Right t -> check_timestamp old_summary location src_fn t Left e | isDoesNotExistError e -> find_it - | otherwise -> liftIO $ ioError e + | otherwise -> ioError e | otherwise = find_it where @@ -2075,7 +2082,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) check_timestamp old_summary location src_fn src_timestamp | ms_hs_date old_summary == src_timestamp = do -- update the object-file timestamp - obj_timestamp <- liftIO $ + obj_timestamp <- if isObjectTarget (hscTarget (hsc_dflags hsc_env)) || obj_allowed -- bug #1205 then getObjTimestamp location is_boot @@ -2090,8 +2097,8 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) -- previously a package module, it may have now appeared on the -- search path, so we want to consider it to be a home module. If -- the module was previously a home module, it may have moved. - liftIO $ uncacheModule hsc_env wanted_mod - found <- liftIO $ findImportedModule hsc_env wanted_mod Nothing + uncacheModule hsc_env wanted_mod + found <- findImportedModule hsc_env wanted_mod Nothing case found of Found location mod | isJust (ml_hs_file location) -> @@ -2102,7 +2109,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) ASSERT(modulePackageId mod /= thisPackage dflags) return Nothing - err -> liftIO $ noModError dflags loc wanted_mod err + err -> noModError dflags loc wanted_mod err -- Not found just_found location mod = do @@ -2114,7 +2121,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) -- Check that it exists -- It might have been deleted since the Finder last found it - maybe_t <- liftIO $ modificationTimeIfExists src_fn + maybe_t <- modificationTimeIfExists src_fn case maybe_t of Nothing -> noHsFileErr loc src_fn Just t -> new_summary location' mod src_fn t @@ -2125,16 +2132,16 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) -- Preprocess the source file and get its imports -- The dflags' contains the OPTIONS pragmas (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf - (srcimps, the_imps, L mod_loc mod_name) <- liftIO $ getImports dflags' buf hspp_fn src_fn + (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn when (mod_name /= wanted_mod) $ - throwErrMsg $ mkPlainErrMsg mod_loc $ + throwOneError $ 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 <- liftIO $ + obj_timestamp <- if isObjectTarget (hscTarget (hsc_dflags hsc_env)) || obj_allowed -- bug #1205 then getObjTimestamp location is_boot @@ -2158,16 +2165,15 @@ getObjTimestamp location is_boot else modificationTimeIfExists (ml_obj_file location) -preprocessFile :: GhcMonad m => - HscEnv +preprocessFile :: HscEnv -> FilePath -> Maybe Phase -- ^ Starting phase -> Maybe (StringBuffer,ClockTime) - -> m (DynFlags, FilePath, StringBuffer) + -> IO (DynFlags, FilePath, StringBuffer) preprocessFile hsc_env src_fn mb_phase Nothing = do (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase) - buf <- liftIO $ hGetStringBuffer hspp_fn + buf <- hGetStringBuffer hspp_fn return (dflags', hspp_fn, buf) preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) @@ -2179,15 +2185,15 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) -- (dflags', leftovers, warns) <- parseDynamicNoPackageFlags dflags local_opts - liftIO $ checkProcessArgsResult leftovers -- XXX: throws exceptions - liftIO $ handleFlagWarnings dflags' warns -- XXX: throws exceptions + checkProcessArgsResult leftovers + handleFlagWarnings dflags' warns let needs_preprocessing | Just (Unlit _) <- mb_phase = True | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True -- note: local_opts is only required if there's no Unlit phase - | dopt Opt_Cpp dflags' = True + | xopt Opt_Cpp dflags' = True | dopt Opt_Pp dflags' = True | otherwise = False @@ -2204,21 +2210,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 - = throwErrMsg $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err + = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err -noHsFileErr :: SrcSpan -> String -> a +noHsFileErr :: SrcSpan -> String -> IO a noHsFileErr loc path - = throwErrMsg $ mkPlainErrMsg loc $ text "Can't find" <+> text path + = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path -packageModErr :: ModuleName -> a +packageModErr :: ModuleName -> IO a packageModErr mod - = throwErrMsg $ mkPlainErrMsg noSrcSpan $ + = throwOneError $ mkPlainErrMsg noSrcSpan $ text "module" <+> quotes (ppr mod) <+> text "is a package module" multiRootsErr :: [ModSummary] -> IO () multiRootsErr [] = panic "multiRootsErr" multiRootsErr summs@(summ1:_) - = throwErrMsg $ mkPlainErrMsg noSrcSpan $ + = throwOneError $ mkPlainErrMsg noSrcSpan $ text "module" <+> quotes (ppr mod) <+> text "is defined in multiple files:" <+> sep (map text files) @@ -2231,18 +2237,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) @@ -2253,6 +2269,15 @@ workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches) getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary getModuleGraph = liftM hsc_mod_graph getSession +-- | Determines whether a set of modules requires Template Haskell. +-- +-- Note that if the session's 'DynFlags' enabled Template Haskell when +-- 'depanal' was called, then each module in the returned module graph will +-- have Template Haskell enabled whether it is actually needed or not. +needsTemplateHaskell :: ModuleGraph -> Bool +needsTemplateHaskell ms = + any (xopt Opt_TemplateHaskell . ms_hspp_opts) ms + -- | Return @True@ <==> module is loaded. isLoaded :: GhcMonad m => ModuleName -> m Bool isLoaded m = withSession $ \hsc_env -> @@ -2264,14 +2289,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 -> @@ -2309,7 +2330,7 @@ getModuleInfo mdl = withSession $ \hsc_env -> do getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) #ifdef GHCI getPackageModuleInfo hsc_env mdl = do - (_msgs, mb_avails) <- getModuleExports hsc_env mdl + mb_avails <- hscGetModuleExports hsc_env mdl case mb_avails of Nothing -> return Nothing Just avails -> do @@ -2323,7 +2344,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 })) @@ -2400,9 +2421,12 @@ isDictonaryId id -- 'setContext'. lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing) lookupGlobalName name = withSession $ \hsc_env -> do - eps <- liftIO $ readIORef (hsc_EPS hsc_env) - return $! lookupType (hsc_dflags hsc_env) - (hsc_HPT hsc_env) (eps_PTE eps) name + liftIO $ lookupTypeHscEnv hsc_env name + +findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a] +findGlobalAnns deserialize target = withSession $ \hsc_env -> do + ann_env <- liftIO $ prepareAnnotations hsc_env Nothing + return (findAnns deserialize ann_env target) #ifdef GHCI -- | get the GlobalRdrEnv for a session @@ -2411,6 +2435,23 @@ getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env) #endif -- ----------------------------------------------------------------------------- + +-- | Return all /external/ modules available in the package database. +-- Modules from the current session (i.e., from the 'HomePackageTable') are +-- not included. +packageDbModules :: GhcMonad m => + Bool -- ^ Only consider exposed packages. + -> m [Module] +packageDbModules only_exposed = do + dflags <- getSessionDynFlags + let pkgs = eltsUFM (pkgIdMap (pkgState dflags)) + return $ + [ mkModule pid modname | p <- pkgs + , not only_exposed || exposed p + , let pid = packageConfigId p + , modname <- exposedModules p ] + +-- ----------------------------------------------------------------------------- -- Misc exported utils dataConType :: DataCon -> Type @@ -2458,7 +2499,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) @@ -2469,7 +2510,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) @@ -2500,7 +2541,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 @@ -2522,23 +2563,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 @@ -2556,3 +2632,34 @@ 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 -> + liftIO $ hscTcRcLookupName hsc_env name + +-- ----------------------------------------------------------------------------- +-- Pure API + +-- | A pure interface to the module parser. +-- +parser :: String -- ^ Haskell module source text (full Unicode is supported) + -> DynFlags -- ^ the flags + -> FilePath -- ^ the filename (for source locations) + -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName)) + +parser str dflags filename = + let + loc = mkSrcLoc (mkFastString filename) 1 1 + buf = stringToStringBuffer str + in + case unP Parser.parseModule (mkPState dflags buf loc) of + + PFailed span err -> + Left (unitBag (mkPlainErrMsg span err)) + + POk pst rdr_module -> + let (warns,_) = getMessages pst in + Right (warns, rdr_module)