X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=5289f71ef0a7ffc2897572736caf9be8e37414e3;hp=dcfd02ac69fd28b9d58ed2c100150553c4540aa2;hb=2fe38b5fb0957f9428864afd69ad3ccd82fae3d0;hpb=ea855a5fdc3abe2cf5b557be9449596d59dc2901 diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index dcfd02a..5289f71 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -8,10 +8,17 @@ module GHC ( -- * Initialisation - Session, defaultErrorHandler, defaultCleanupHandler, - newSession, + + -- * GHC Monad + Ghc, GhcT, GhcMonad(..), + runGhc, runGhcT, initGhcMonad, + gcatch, gbracket, gfinally, + clearWarnings, getWarnings, hasWarnings, + printExceptionAndWarnings, printWarnings, + handleSourceError, defaultCallbacks, GhcApiCallbacks(..), + needsTemplateHaskell, -- * Flags and settings DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt, @@ -19,7 +26,7 @@ module GHC ( parseDynamicFlags, getSessionDynFlags, setSessionDynFlags, - parseStaticFlags, + parseStaticFlags, -- * Targets Target(..), TargetId(..), Phase, @@ -30,21 +37,26 @@ module GHC ( guessTarget, -- * Extending the program scope - extendGlobalRdrScope, -- :: Session -> [GlobalRdrElt] -> IO () - setGlobalRdrScope, -- :: Session -> [GlobalRdrElt] -> IO () - extendGlobalTypeScope, -- :: Session -> [Id] -> IO () - setGlobalTypeScope, -- :: Session -> [Id] -> IO () + extendGlobalRdrScope, + setGlobalRdrScope, + extendGlobalTypeScope, + setGlobalTypeScope, -- * Loading\/compiling the program depanal, - load, LoadHowMuch(..), SuccessFlag(..), -- also does depanal + load, loadWithLogger, LoadHowMuch(..), + SuccessFlag(..), succeeded, failed, + defaultWarnErrLogger, WarnErrLogger, workingDirectoryChanged, - checkModule, CheckedModule(..), - TypecheckedSource, ParsedSource, RenamedSource, - compileToCore, - - -- * Parsing Haddock comments - parseHaddockComment, + parseModule, typecheckModule, desugarModule, loadModule, + ParsedModule(..), TypecheckedModule(..), DesugaredModule(..), + TypecheckedSource, ParsedSource, RenamedSource, -- ditto + TypecheckedMod, ParsedMod, + moduleInfo, renamedSource, typecheckedSource, + parsedSource, coreModule, + compileToCoreModule, compileToCoreSimplified, + compileCoreToObj, + getModSummary, -- * Inspecting the module structure of the program ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..), @@ -57,12 +69,16 @@ module GHC ( getModuleInfo, modInfoTyThings, modInfoTopLevelScope, - modInfoPrintUnqualified, - modInfoExports, + modInfoExports, modInfoInstances, modInfoIsExportedName, modInfoLookupName, lookupGlobalName, + findGlobalAnns, + mkPrintUnqualifiedForModule, + + -- * Querying the environment + packageDbModules, -- * Printing PrintUnqualified, alwaysQualify, @@ -70,10 +86,12 @@ module GHC ( -- * Interactive evaluation getBindings, getPrintUnqual, findModule, + lookupModule, #ifdef GHCI setContext, getContext, getNamesInScope, getRdrNamesInScope, + getGRE, moduleIsInterpreted, getInfo, exprType, @@ -92,9 +110,9 @@ module GHC ( InteractiveEval.forward, showModule, isModuleInterpreted, - compileExpr, HValue, dynCompileExpr, + InteractiveEval.compileExpr, HValue, dynCompileExpr, lookupName, - obtainTerm, obtainTerm1, + GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType, modInfoModBreaks, ModBreaks(..), BreakIndex, BreakInfo(breakInfo_number, breakInfo_module), @@ -154,8 +172,8 @@ module GHC ( instanceDFunId, pprInstance, pprInstanceHdr, -- ** Types and Kinds - Type, dropForAlls, splitForAllTys, funResultTy, - pprParendType, pprTypeApp, + Type, splitForAllTys, funResultTy, + pprParendType, pprTypeApp, Kind, PredType, ThetaType, pprThetaArrow, @@ -183,11 +201,30 @@ 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, + -- * Token stream manipulations + Token, + getTokenStream, getRichTokenStream, + showRichTokenStream, addSourceToTokens, + -- * Miscellaneous - sessionHscEnv, + --sessionHscEnv, cyclicModuleErr, ) where @@ -205,72 +242,78 @@ import qualified Linker import Linker ( HValue ) import ByteCodeInstr import BreakArray -import NameSet -import TcRnDriver import InteractiveEval +import TcRnDriver #endif +import TcIface +import TcRnTypes hiding (LIE) +import TcRnMonad ( initIfaceCheck ) import Packages import NameSet import RdrName -import HsSyn +import qualified HsSyn -- hack as we want to reexport the whole module +import HsSyn hiding ((<.>)) import Type hiding (typeKind) import TcType hiding (typeKind) import Id -import Var hiding (setIdType) +import Var import TysPrim ( alphaTyVars ) import TyCon import Class -import FunDeps +-- import FunDeps import DataCon import Name hiding ( varName ) -import OccName ( parenSymOcc ) -import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr ) +-- import OccName ( parenSymOcc ) +import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr, + emptyInstEnv ) +import FamInstEnv ( emptyFamInstEnv ) import SrcLoc -import Desugar -import CoreSyn -import TcRnDriver ( tcRnModule ) +--import CoreSyn +import TidyPgm import DriverPipeline -import DriverPhases ( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase ) -import HeaderInfo ( getImports, getOptions ) +import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase ) +import HeaderInfo import Finder -import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) ) +import HscMain import HscTypes import DynFlags -import StaticFlags +import StaticFlagParser +import qualified StaticFlags import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept, cleanTempDirs ) +import Annotations import Module -import UniqFM -import UniqSet -import Unique -import PackageConfig +import LazyUniqFM +import qualified UniqFM as UFM import FiniteMap import Panic import Digraph -import Bag ( unitBag, listToBag ) -import ErrUtils ( Severity(..), showPass, fatalErrorMsg, debugTraceMsg, - mkPlainErrMsg, printBagOfErrors, printBagOfWarnings, - WarnMsg ) -import qualified ErrUtils +import Bag ( unitBag, listToBag, emptyBag, isEmptyBag ) +import ErrUtils +import MonadUtils import Util -import StringBuffer ( StringBuffer, hGetStringBuffer ) +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 ) +import System.Directory ( getModificationTime, doesFileExist, + getCurrentDirectory ) import Data.Maybe 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 ) -import Control.Exception as Exception hiding (handle) +import System.Time ( ClockTime, getClockTime ) +import Exception import Data.IORef +import System.FilePath import System.IO import System.IO.Error ( try, isDoesNotExistError ) import Prelude hiding (init) @@ -283,81 +326,159 @@ import Prelude hiding (init) -- Unless you want to handle exceptions yourself, you should wrap this around -- the top level of your program. The default handlers output the error -- message(s) to stderr and exit cleanly. -defaultErrorHandler :: DynFlags -> IO a -> IO a -defaultErrorHandler dflags inner = +defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => DynFlags -> m a -> m a +defaultErrorHandler dflags inner = -- top-level exception handler: any unrecognised exception is a compiler bug. - handle (\exception -> do - hFlush stdout - case exception of - -- an IO exception probably isn't our fault, so don't panic - IOException _ -> - fatalErrorMsg dflags (text (show exception)) - AsyncException StackOverflow -> - fatalErrorMsg dflags (text "stack overflow: use +RTS -K to increase it") - _other -> - fatalErrorMsg dflags (text (show (Panic (show exception)))) - exitWith (ExitFailure 1) + ghandle (\exception -> liftIO $ do + hFlush stdout + case fromException exception of + -- an IO exception probably isn't our fault, so don't panic + Just (ioe :: IOException) -> + fatalErrorMsg dflags (text (show ioe)) + _ -> case fromException exception of + Just StackOverflow -> + fatalErrorMsg dflags (text "stack overflow: use +RTS -K to increase it") + _ -> case fromException exception of + Just (ex :: ExitCode) -> throw ex + _ -> + fatalErrorMsg dflags + (text (show (Panic (show exception)))) + exitWith (ExitFailure 1) ) $ - -- program errors: messages with locations attached. Sometimes it is - -- convenient to just throw these as exceptions. - handleDyn (\dyn -> do printBagOfErrors dflags (unitBag dyn) - exitWith (ExitFailure 1)) $ - -- error messages propagated as exceptions - handleDyn (\dyn -> do + handleGhcException + (\ge -> liftIO $ do hFlush stdout - case dyn of + case ge of PhaseFailed _ code -> exitWith code Interrupted -> exitWith (ExitFailure 1) - _ -> do fatalErrorMsg dflags (text (show (dyn :: GhcException))) + _ -> do fatalErrorMsg dflags (text (show ge)) exitWith (ExitFailure 1) ) $ inner --- | Install a default cleanup handler to remove temporary files --- deposited by a GHC run. This is seperate from --- 'defaultErrorHandler', because you might want to override the error --- handling, but still get the ordinary cleanup behaviour. -defaultCleanupHandler :: DynFlags -> IO a -> IO a -defaultCleanupHandler dflags inner = +-- | Install a default cleanup handler to remove temporary files deposited by +-- a GHC run. This is seperate from 'defaultErrorHandler', because you might +-- want to override the error handling, but still get the ordinary cleanup +-- behaviour. +defaultCleanupHandler :: (ExceptionMonad m, MonadIO m) => + DynFlags -> m a -> m a +defaultCleanupHandler dflags inner = -- make sure we clean up after ourselves - later (do cleanTempFiles dflags + inner `gfinally` + (liftIO $ do + cleanTempFiles dflags cleanTempDirs dflags ) - -- exceptions will be blocked while we clean the temporary files, + -- exceptions will be blocked while we clean the temporary files, -- so there shouldn't be any difficulty if we receive further -- signals. - inner - --- | Starts a new session. A session consists of a set of loaded --- modules, a set of options (DynFlags), and an interactive context. -newSession :: Maybe FilePath -> IO Session -newSession mb_top_dir = do +-- | Print the error message and all warnings. Useful inside exception +-- handlers. Clears warnings after printing. +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 + +-- | Run function for the 'Ghc' monad. +-- +-- It initialises the GHC session and warnings via 'initGhcMonad'. Each call +-- to this function will create a new session which should not be shared among +-- several threads. +-- +-- Any errors not handled inside the 'Ghc' action are propagated as IO +-- exceptions. + +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 + flip unGhc session $ do + initGhcMonad mb_top_dir + ghc + -- XXX: unregister interrupt handlers here? + +-- | Run function for 'GhcT' monad transformer. +-- +-- It initialises the GHC session and warnings via 'initGhcMonad'. Each call +-- to this function will create a new session which should not be shared among +-- several threads. + +runGhcT :: (ExceptionMonad m, Functor m, MonadIO m) => + Maybe FilePath -- ^ See argument to 'initGhcMonad'. + -> 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 + flip unGhcT session $ do + initGhcMonad mb_top_dir + ghct + +-- | Initialise a GHC session. +-- +-- If you implement a custom 'GhcMonad' you must call this function in the +-- monad run function. It will initialise the session variable and clear all +-- warnings. +-- +-- The first argument should point to the directory where GHC's library files +-- reside. More precisely, this should be the output of @ghc --print-libdir@ +-- of the version of GHC the module using this API is compiled with. For +-- portability, you should use the @ghc-paths@ package, available at +-- . + +initGhcMonad :: GhcMonad m => Maybe FilePath -> m () +initGhcMonad mb_top_dir = do -- catch ^C - main_thread <- myThreadId - modifyMVar_ interruptTargetThread (return . (main_thread :)) - installSignalHandlers - - initStaticOpts - dflags0 <- initSysTools mb_top_dir defaultDynFlags - dflags <- initDynFlags dflags0 - env <- newHscEnv dflags - ref <- newIORef env - return (Session ref) - --- tmp: this breaks the abstraction, but required because DriverMkDepend --- needs to call the Finder. ToDo: untangle this. -sessionHscEnv :: Session -> IO HscEnv -sessionHscEnv (Session ref) = readIORef ref + main_thread <- liftIO $ myThreadId + liftIO $ modifyMVar_ interruptTargetThread (return . (main_thread :)) + liftIO $ installSignalHandlers + + liftIO $ StaticFlags.initStaticOpts + + dflags0 <- liftIO $ initDynFlags defaultDynFlags + dflags <- liftIO $ initSysTools mb_top_dir dflags0 + env <- liftIO $ newHscEnv defaultCallbacks dflags + setSession env + clearWarnings + +defaultCallbacks :: GhcApiCallbacks +defaultCallbacks = + GhcApiCallbacks { + reportModuleCompilationResult = + \_ mb_err -> defaultWarnErrLogger mb_err + } -- ----------------------------------------------------------------------------- -- Flags & settings -- | Grabs the DynFlags from the Session -getSessionDynFlags :: Session -> IO DynFlags -getSessionDynFlags s = withSession s (return . hsc_dflags) +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), @@ -370,29 +491,37 @@ getSessionDynFlags s = withSession s (return . hsc_dflags) -- flags. If you are not doing linking or doing static linking, you -- can ignore the list of packages returned. -- -setSessionDynFlags :: Session -> DynFlags -> IO [PackageId] -setSessionDynFlags (Session ref) dflags = do - hsc_env <- readIORef ref - (dflags', preload) <- initPackages dflags - writeIORef ref $! hsc_env{ hsc_dflags = dflags' } +setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageId] +setSessionDynFlags dflags = do + (dflags', preload) <- liftIO $ initPackages dflags + modifySession (\h -> h{ hsc_dflags = dflags' }) return preload -- | If there is no -o option, guess the name of target executable -- by using top-level source file name as a base. -guessOutputFile :: Session -> IO () -guessOutputFile s = modifySession s $ \env -> +guessOutputFile :: GhcMonad m => m () +guessOutputFile = modifySession $ \env -> let dflags = hsc_dflags env mod_graph = hsc_mod_graph env - mainModuleSrcPath, guessedName :: Maybe String + mainModuleSrcPath :: Maybe String mainModuleSrcPath = do let isMain = (== mainModIs dflags) . ms_mod [ms] <- return (filter isMain mod_graph) ml_hs_file (ms_location ms) - guessedName = fmap basenameOf mainModuleSrcPath + name = fmap dropExtension mainModuleSrcPath + +#if defined(mingw32_HOST_OS) + -- we must add the .exe extention unconditionally here, otherwise + -- when name has an extension of its own, the .exe extension will + -- not be added by DriverPipeline.exeFileName. See #2248 + name_exe = fmap (<.> "exe") name +#else + name_exe = name +#endif in case outputFile dflags of Just _ -> env - Nothing -> env { hsc_dflags = dflags { outputFile = guessedName } } + Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } } -- ----------------------------------------------------------------------------- -- Targets @@ -403,156 +532,191 @@ guessOutputFile s = modifySession s $ \env -> -- | Sets the targets for this session. Each target may be a module name -- or a filename. The targets correspond to the set of root modules for -- the program\/library. Unloading the current program is achieved by --- setting the current set of targets to be empty, followed by load. -setTargets :: Session -> [Target] -> IO () -setTargets s targets = modifySession s (\h -> h{ hsc_targets = targets }) +-- setting the current set of targets to be empty, followed by 'load'. +setTargets :: GhcMonad m => [Target] -> m () +setTargets targets = modifySession (\h -> h{ hsc_targets = targets }) --- | returns the current set of targets -getTargets :: Session -> IO [Target] -getTargets s = withSession s (return . hsc_targets) +-- | Returns the current set of targets +getTargets :: GhcMonad m => m [Target] +getTargets = withSession (return . hsc_targets) --- | Add another target -addTarget :: Session -> Target -> IO () -addTarget s target - = modifySession s (\h -> h{ hsc_targets = target : hsc_targets h }) +-- | Add another target. +addTarget :: GhcMonad m => Target -> m () +addTarget target + = modifySession (\h -> h{ hsc_targets = target : hsc_targets h }) -- | Remove a target -removeTarget :: Session -> TargetId -> IO () -removeTarget s target_id - = modifySession s (\h -> h{ hsc_targets = filter (hsc_targets h) }) +removeTarget :: GhcMonad m => TargetId -> m () +removeTarget target_id + = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) }) where - filter targets = [ t | t@(Target id _) <- targets, id /= target_id ] + filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ] --- Attempts to guess what Target a string refers to. This function implements --- the --make/GHCi command-line syntax for filenames: +-- | Attempts to guess what Target a string refers to. This function +-- implements the @--make@/GHCi command-line syntax for filenames: +-- +-- - if the string looks like a Haskell source filename, then interpret it +-- as such +-- +-- - if adding a .hs or .lhs suffix yields the name of an existing file, +-- then use that -- --- - if the string looks like a Haskell source filename, then interpret --- it as such --- - if adding a .hs or .lhs suffix yields the name of an existing file, --- then use that --- - otherwise interpret the string as a module name +-- - otherwise interpret the string as a module name -- -guessTarget :: String -> Maybe Phase -> IO Target -guessTarget file (Just phase) - = return (Target (TargetFile file (Just phase)) Nothing) -guessTarget file Nothing +guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target +guessTarget str (Just phase) + = return (Target (TargetFile str (Just phase)) True Nothing) +guessTarget str Nothing | isHaskellSrcFilename file - = return (Target (TargetFile file Nothing) Nothing) + = return (target (TargetFile file Nothing)) | otherwise - = do exists <- doesFileExist hs_file + = do exists <- liftIO $ doesFileExist hs_file if exists - then return (Target (TargetFile hs_file Nothing) Nothing) + then return (target (TargetFile hs_file Nothing)) else do - exists <- doesFileExist lhs_file + exists <- liftIO $ doesFileExist lhs_file if exists - then return (Target (TargetFile lhs_file Nothing) Nothing) + then return (target (TargetFile lhs_file Nothing)) else do - return (Target (TargetModule (mkModuleName file)) Nothing) + if looksLikeModuleName file + then return (target (TargetModule (mkModuleName file))) + else do + throwGhcException + (ProgramError (showSDoc $ + text "target" <+> quotes (text file) <+> + text "is not a module name or a source file")) where - hs_file = file `joinFileExt` "hs" - lhs_file = file `joinFileExt` "lhs" + (file,obj_allowed) + | '*':rest <- str = (rest, False) + | otherwise = (str, True) + + hs_file = file <.> "hs" + lhs_file = file <.> "lhs" + + target tid = Target tid obj_allowed Nothing -- ----------------------------------------------------------------------------- -- Extending the program scope -extendGlobalRdrScope :: Session -> [GlobalRdrElt] -> IO () -extendGlobalRdrScope session rdrElts - = modifySession session $ \hscEnv -> +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 :: Session -> [GlobalRdrElt] -> IO () -setGlobalRdrScope session rdrElts - = modifySession session $ \hscEnv -> +setGlobalRdrScope :: GhcMonad m => [GlobalRdrElt] -> m () +setGlobalRdrScope rdrElts + = modifySession $ \hscEnv -> hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv emptyGlobalRdrEnv rdrElts } -extendGlobalTypeScope :: Session -> [Id] -> IO () -extendGlobalTypeScope session ids - = modifySession session $ \hscEnv -> +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 :: Session -> [Id] -> IO () -setGlobalTypeScope session ids - = modifySession session $ \hscEnv -> +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 = parseHaddockParagraphs (tokenise string) - --- ----------------------------------------------------------------------------- -- Loading the program --- Perform a dependency analysis starting from the current targets +-- | Perform a dependency analysis starting from the current targets -- and update the session with the new module graph. -depanal :: Session -> [ModuleName] -> Bool -> IO (Maybe ModuleGraph) -depanal (Session ref) excluded_mods allow_dup_roots = do - hsc_env <- readIORef ref +-- +-- 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 + -> m ModuleGraph +depanal excluded_mods allow_dup_roots = do + hsc_env <- getSession let dflags = hsc_dflags hsc_env targets = hsc_targets hsc_env old_graph = hsc_mod_graph hsc_env - showPass dflags "Chasing dependencies" - debugTraceMsg dflags 2 (hcat [ + liftIO $ showPass dflags "Chasing dependencies" + liftIO $ debugTraceMsg dflags 2 (hcat [ text "Chasing modules from: ", hcat (punctuate comma (map pprTarget targets))]) - r <- downsweep hsc_env old_graph excluded_mods allow_dup_roots - case r of - Just mod_graph -> writeIORef ref hsc_env{ hsc_mod_graph = mod_graph } - _ -> return () - return r - -{- --- | The result of load. -data LoadResult - = LoadOk Errors -- ^ all specified targets were loaded successfully. - | LoadFailed Errors -- ^ not all modules were loaded. - -type Errors = [String] - -data ErrMsg = ErrMsg { - errMsgSeverity :: Severity, -- warning, error, etc. - errMsgSpans :: [SrcSpan], - errMsgShortDoc :: Doc, - errMsgExtraInfo :: Doc - } --} + mod_graph <- 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. 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 = 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 -- | 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. -load :: Session -> LoadHowMuch -> IO SuccessFlag -load s@(Session ref) 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. - mb_graph <- depanal s [] False - case mb_graph of - Just mod_graph -> catchingFailure $ load2 s how_much mod_graph - Nothing -> return Failed - where catchingFailure f = f `Exception.catch` \e -> do - hsc_env <- readIORef ref - -- trac #1565 / test ghci021: - -- let bindings may explode if we try to use them after - -- failing to reload - writeIORef ref $! hsc_env{ hsc_IC = emptyInteractiveContext } - throw e - -load2 s@(Session ref) how_much mod_graph = do - guessOutputFile s - hsc_env <- readIORef ref +-- +-- The first argument is a function that is called after compiling each +-- module to print wanrings and errors. +-- +-- While compiling a module, all 'SourceError's are caught and passed to the +-- logger, however, this function may still throw a 'SourceError' if +-- dependency analysis failed (e.g., due to a parse error). +-- +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. + withLocalCallbacks (\cbs -> cbs { reportModuleCompilationResult = + \_ -> logger }) $ + load how_much + +load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] + -> m SuccessFlag +load2 how_much mod_graph = do + guessOutputFile + hsc_env <- getSession let hpt1 = hsc_HPT hsc_env let dflags = hsc_dflags hsc_env @@ -563,12 +727,25 @@ load2 s@(Session ref) how_much mod_graph = do -- (see msDeps) let all_home_mods = [ms_mod_name s | s <- mod_graph, not (isBootSummary s)] -#ifdef DEBUG bad_boot_mods = [s | s <- mod_graph, isBootSummary s, not (ms_mod_name s `elem` all_home_mods)] -#endif ASSERT( null bad_boot_mods ) return () + -- check that the module given in HowMuch actually exists, otherwise + -- topSortModuleGraph will bomb later. + let checkHowMuch (LoadUpTo m) = checkMod m + checkHowMuch (LoadDependenciesOf m) = checkMod m + checkHowMuch _ = id + + checkMod m and_then + | m `elem` all_home_mods = and_then + | otherwise = do + liftIO $ errorMsg dflags (text "no such module:" <+> + quotes (ppr m)) + return Failed + + checkHowMuch how_much $ do + -- mg2_with_srcimps drops the hi-boot nodes, returning a -- graph with cycles. Among other things, it is used for -- backing out partially complete cycles following a failed @@ -579,7 +756,7 @@ load2 s@(Session ref) how_much mod_graph = 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. @@ -592,9 +769,15 @@ load2 s@(Session ref) how_much mod_graph = do (flattenSCCs mg2_with_srcimps) stable_mods - 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, + -- write the pruned HPT to allow the old HPT to be GC'd. + modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext, + hsc_HPT = pruned_hpt } - debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ + liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ text "Stable BCO:" <+> ppr stable_bco) -- Unload any modules which are going to be re-linked this time around. @@ -602,7 +785,7 @@ load2 s@(Session ref) how_much mod_graph = do | m <- stable_obj++stable_bco, Just hmi <- [lookupUFM pruned_hpt m], Just linkable <- [hm_linkable hmi] ] - unload hsc_env stable_linkables + liftIO $ unload hsc_env stable_linkables -- We could at this point detect cycles which aren't broken by -- a source-import, and complain immediately, but it seems better @@ -635,9 +818,9 @@ load2 s@(Session ref) how_much mod_graph = do -- short of the specified module (unless the specified module -- is stable). partial_mg - | LoadDependenciesOf mod <- how_much + | LoadDependenciesOf _mod <- how_much = ASSERT( case last partial_mg0 of - AcyclicSCC ms -> ms_mod_name ms == mod; _ -> False ) + AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False ) List.init partial_mg0 | otherwise = partial_mg0 @@ -655,11 +838,11 @@ load2 s@(Session ref) how_much mod_graph = do let cleanup = cleanTempFilesExcept dflags (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps)) - debugTraceMsg dflags 2 (hang (text "Ready for upsweep") + liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") 2 (ppr mg)) (upsweep_ok, hsc_env1, modsUpswept) <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable }) - pruned_hpt stable_mods cleanup mg + pruned_hpt stable_mods cleanup mg -- Make modsDone be the summaries for each home module now -- available; this should equal the domain of hpt3. @@ -674,10 +857,10 @@ load2 s@(Session ref) how_much mod_graph = do then -- Easy; just relink it all. - do debugTraceMsg dflags 2 (text "Upsweep completely successful.") + do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.") -- Clean up after ourselves - cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone) + liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone) -- Issue a warning for the confusing case where the user -- said '-o foo' but we're not going to do any linking. @@ -690,26 +873,26 @@ load2 s@(Session ref) 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) $ - debugTraceMsg dflags 1 $ + liftIO $ debugTraceMsg dflags 1 $ text ("Warning: output was redirected with -o, " ++ "but no output will be generated\n" ++ "because there is no " ++ moduleNameString (moduleName main_mod) ++ " module.") -- link everything together - linkresult <- link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) + linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) - loadFinish Succeeded linkresult ref hsc_env1 + loadFinish Succeeded linkresult hsc_env1 else -- Tricky. We need to back out the effects of compiling any -- half-done cycles, both so as to clean up the top level envs -- and to avoid telling the interactive linker to link them. - do debugTraceMsg dflags 2 (text "Upsweep partially successful.") + do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.") let modsDone_names = map ms_mod modsDone @@ -724,30 +907,33 @@ load2 s@(Session ref) how_much mod_graph = do (hsc_HPT hsc_env1) -- Clean up after ourselves - cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep) + liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep) -- there should be no Nothings where linkables should be, now ASSERT(all (isJust.hm_linkable) (eltsUFM (hsc_HPT hsc_env))) do -- Link everything together - linkresult <- link (ghcLink dflags) dflags False hpt4 + linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4 let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 } - loadFinish Failed linkresult ref hsc_env4 + loadFinish Failed linkresult hsc_env4 -- Finish up after a load. -- If the link failed, unload everything and return. -loadFinish all_ok Failed ref hsc_env - = do unload hsc_env [] - writeIORef ref $! discardProg hsc_env +loadFinish :: GhcMonad m => + SuccessFlag -> SuccessFlag -> HscEnv + -> m SuccessFlag +loadFinish _all_ok Failed hsc_env + = do liftIO $ unload hsc_env [] + modifySession $ \_ -> discardProg hsc_env 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 ref hsc_env - = do writeIORef ref $! hsc_env{ hsc_IC = emptyInteractiveContext } +loadFinish all_ok Succeeded hsc_env + = do modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext } return all_ok @@ -761,27 +947,81 @@ discardProg hsc_env -- used to fish out the preprocess output files for the purposes of -- cleaning up. The preprocessed file *might* be the same as the -- source file, but that doesn't do any harm. +ppFilesFromSummaries :: [ModSummary] -> [FilePath] ppFilesFromSummaries summaries = map ms_hspp_file summaries -- ----------------------------------------------------------------------------- --- Check module - -data CheckedModule = - CheckedModule { parsedSource :: ParsedSource, - renamedSource :: Maybe RenamedSource, - typecheckedSource :: Maybe TypecheckedSource, - checkedModuleInfo :: Maybe ModuleInfo, - coreBinds :: Maybe [CoreBind] - } + +class ParsedMod m where + modSummary :: m -> ModSummary + parsedSource :: m -> ParsedSource + +class ParsedMod m => TypecheckedMod m where + renamedSource :: m -> Maybe RenamedSource + typecheckedSource :: m -> TypecheckedSource + moduleInfo :: m -> ModuleInfo + tm_internals :: m -> (TcGblEnv, ModDetails) -- ToDo: improvements that could be made here: -- if the module succeeded renaming but not typechecking, -- we can still get back the GlobalRdrEnv and exports, so -- perhaps the ModuleInfo should be split up into separate - -- fields within CheckedModule. + -- fields. + +class TypecheckedMod m => DesugaredMod m where + coreModule :: m -> ModGuts + +-- | The result of successful parsing. +data ParsedModule = + ParsedModule { pm_mod_summary :: ModSummary + , pm_parsed_source :: ParsedSource } + +instance ParsedMod ParsedModule where + modSummary m = pm_mod_summary m + parsedSource m = pm_parsed_source m + +-- | The result of successful typechecking. It also contains the parser +-- result. +data TypecheckedModule = + TypecheckedModule { tm_parsed_module :: ParsedModule + , tm_renamed_source :: Maybe RenamedSource + , tm_typechecked_source :: TypecheckedSource + , tm_checked_module_info :: ModuleInfo + , tm_internals_ :: (TcGblEnv, ModDetails) + } + +instance ParsedMod TypecheckedModule where + modSummary m = modSummary (tm_parsed_module m) + parsedSource m = parsedSource (tm_parsed_module m) + +instance TypecheckedMod TypecheckedModule where + renamedSource m = tm_renamed_source m + typecheckedSource m = tm_typechecked_source m + moduleInfo m = tm_checked_module_info m + tm_internals m = tm_internals_ m + +-- | The result of successful desugaring (i.e., translation to core). Also +-- contains all the information of a typechecked module. +data DesugaredModule = + DesugaredModule { dm_typechecked_module :: TypecheckedModule + , dm_core_module :: ModGuts + } + +instance ParsedMod DesugaredModule where + modSummary m = modSummary (dm_typechecked_module m) + parsedSource m = parsedSource (dm_typechecked_module m) + +instance TypecheckedMod DesugaredModule where + renamedSource m = renamedSource (dm_typechecked_module m) + typecheckedSource m = typecheckedSource (dm_typechecked_module m) + moduleInfo m = moduleInfo (dm_typechecked_module m) + tm_internals m = tm_internals_ (dm_typechecked_module m) + +instance DesugaredMod DesugaredModule where + coreModule m = dm_core_module m 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: @@ -796,78 +1036,235 @@ type TypecheckedSource = LHsBinds Id -- - default methods are turned into top-level decls. -- - dictionary bindings - --- | This is the way to get access to parsed and typechecked source code --- for a module. 'checkModule' attempts to typecheck the module. If --- successful, it returns the abstract syntax for the module. --- If compileToCore is true, it also desugars the module and returns the --- resulting Core bindings as a component of the CheckedModule. -checkModule :: Session -> ModuleName -> Bool -> IO (Maybe CheckedModule) -checkModule session@(Session ref) mod compileToCore = do - -- parse & typecheck the module - hsc_env <- readIORef ref - let mg = hsc_mod_graph hsc_env - case [ ms | ms <- mg, ms_mod_name ms == mod ] of - [] -> return Nothing - (ms:_) -> do - mbChecked <- hscFileCheck - hsc_env{hsc_dflags=ms_hspp_opts ms} - ms compileToCore - case mbChecked of - Nothing -> return Nothing - Just (HscChecked parsed renamed Nothing _) -> - return (Just (CheckedModule { - parsedSource = parsed, - renamedSource = renamed, - typecheckedSource = Nothing, - checkedModuleInfo = Nothing, - coreBinds = Nothing })) - Just (HscChecked parsed renamed - (Just (tc_binds, rdr_env, details)) - maybeCoreBinds) -> do - let minf = ModuleInfo { - minf_type_env = md_types details, - minf_exports = availsToNameSet $ - md_exports details, - minf_rdr_env = Just rdr_env, - minf_instances = md_insts details +-- | Return the 'ModSummary' of a module with the given name. +-- +-- The module must be part of the module graph (see 'hsc_mod_graph' and +-- 'ModuleGraph'). If this is not the case, this function will throw a +-- 'GhcApiError'. +-- +-- This function ignores boot modules and requires that there is only one +-- non-boot module with the given name. +getModSummary :: GhcMonad m => ModuleName -> m ModSummary +getModSummary mod = do + mg <- liftM hsc_mod_graph getSession + case [ ms | ms <- mg, ms_mod_name ms == mod, not (isBootSummary ms) ] of + [] -> throw $ mkApiErr (text "Module not part of module graph") + [ms] -> return ms + multiple -> throw $ mkApiErr (text "getModSummary is ambiguous: " <+> ppr multiple) + +-- | Parse a module. +-- +-- Throws a 'SourceError' on parse error. +parseModule :: GhcMonad m => ModSummary -> m ParsedModule +parseModule ms = do + rdr_module <- withTempSession + (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ + hscParse ms + return (ParsedModule ms rdr_module) + +-- | Typecheck and rename a parsed module. +-- +-- Throws a 'SourceError' if either fails. +typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule +typecheckModule pmod = do + let ms = modSummary pmod + withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do + (tc_gbl_env, rn_info) + <- hscTypecheckRename ms (parsedSource pmod) + details <- makeSimpleDetails tc_gbl_env + return $ + TypecheckedModule { + tm_internals_ = (tc_gbl_env, details), + tm_parsed_module = pmod, + tm_renamed_source = rn_info, + tm_typechecked_source = tcg_binds tc_gbl_env, + tm_checked_module_info = + ModuleInfo { + minf_type_env = md_types details, + minf_exports = availsToNameSet $ md_exports details, + minf_rdr_env = Just (tcg_rdr_env tc_gbl_env), + minf_instances = md_insts details #ifdef GHCI - ,minf_modBreaks = emptyModBreaks + ,minf_modBreaks = emptyModBreaks #endif - } - return (Just (CheckedModule { - parsedSource = parsed, - renamedSource = renamed, - typecheckedSource = Just tc_binds, - checkedModuleInfo = Just minf, - coreBinds = maybeCoreBinds})) + }} + +-- | Desugar a typechecked module. +desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule +desugarModule tcm = do + let ms = modSummary tcm + withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do + let (tcg, _) = tm_internals tcm + guts <- hscDesugar ms tcg + return $ + DesugaredModule { + dm_typechecked_module = tcm, + dm_core_module = guts + } + +-- | Load a module. Input doesn't need to be desugared. +-- +-- 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 (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 + hsc_env <- getSession + mod_info + <- compile' (compilerBackend hscNothingCompiler + ,compilerBackend hscInteractiveCompiler + ,compilerBackend hscBatchCompiler) + hsc_env ms 1 1 Nothing Nothing + -- 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' invokes 'checkModule' to parse, typecheck, and --- desugar the module, then returns the resulting list of Core bindings if --- successful. -compileToCore :: Session -> FilePath -> IO (Maybe [CoreBind]) -compileToCore session@(Session ref) fn = do - hsc_env <- readIORef ref +-- to a module. 'compileToCore' parses, typechecks, and +-- desugars the module, then returns the resulting Core module (consisting of +-- the module name, type declarations, and function declarations) if +-- successful. +compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule +compileToCoreModule = compileCore False + +-- | Like compileToCoreModule, but invokes the simplifier, so +-- as to return simplified and tidied Core. +compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule +compileToCoreSimplified = compileCore True +{- +-- | Provided for backwards-compatibility: compileToCore returns just the Core +-- bindings, but for most purposes, you probably want to call +-- compileToCoreModule. +compileToCore :: GhcMonad m => FilePath -> m [CoreBind] +compileToCore fn = do + mod <- compileToCoreModule session fn + return $ cm_binds mod +-} +-- | Takes a CoreModule and compiles the bindings therein +-- to object code. The first argument is a bool flag indicating +-- whether to run the simplifier. +-- The resulting .o, .hi, and executable files, if any, are stored in the +-- current directory, and named according to the module name. +-- 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 + dflags <- getSessionDynFlags + currentTime <- liftIO $ getClockTime + cwd <- liftIO $ getCurrentDirectory + modLocation <- liftIO $ mkHiOnlyModLocation dflags (hiSuf dflags) cwd + ((moduleNameSlashes . moduleName) mName) + + let modSummary = ModSummary { ms_mod = mName, + ms_hsc_src = ExtCoreFile, + ms_location = modLocation, + -- By setting the object file timestamp to Nothing, + -- we always force recompilation, which is what we + -- want. (Thus it doesn't matter what the timestamp + -- for the (nonexistent) source file is.) + ms_hs_date = currentTime, + ms_obj_date = Nothing, + -- Only handling the single-module case for now, so no imports. + ms_srcimps = [], + ms_imps = [], + -- No source file + ms_hspp_file = "", + ms_hspp_opts = dflags, + ms_hspp_buf = Nothing + } + + let maybe_simplify mod_guts | simplify = hscSimplify mod_guts + | otherwise = return mod_guts + guts <- maybe_simplify (mkModGuts cm) + (iface, changed, _details, cgguts) + <- hscNormalIface guts Nothing + hscWriteIface iface changed modSummary + _ <- hscGenHardCode cgguts modSummary + 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_anns = [], + mg_hpc_info = emptyHpcInfo False, + mg_modBreaks = emptyModBreaks, + mg_vect_info = noVectInfo, + mg_inst_env = emptyInstEnv, + mg_fam_inst_env = emptyFamInstEnv +} + +compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule +compileCore simplify fn = do -- First, set the target to the desired filename target <- guessTarget fn Nothing - addTarget session target - load session LoadAllTargets + addTarget target + _ <- load LoadAllTargets -- Then find dependencies - maybeModGraph <- depanal session [] True - case maybeModGraph of - Nothing -> return Nothing - Just modGraph -> do - case find ((== fn) . msHsFilePath) modGraph of - Just modSummary -> do - -- Now we have the module name; - -- parse, typecheck and desugar the module - let mod = ms_mod_name modSummary - maybeCheckedModule <- checkModule session mod True - case maybeCheckedModule of - Nothing -> return Nothing - Just checkedMod -> return $ coreBinds checkedMod - -- --------------------------------------------------------------------------- + modGraph <- depanal [] True + case find ((== fn) . msHsFilePath) modGraph of + Just modSummary -> 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 + then do + -- If simplify is true: simplify (hscSimplify), then tidy + -- (tidyProgram). + hsc_env <- getSession + simpl_guts <- hscSimplify mod_guts + tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts + return $ Left tidy_guts + else + return $ Right mod_guts + + Nothing -> panic "compileToCoreModule: target FilePath not found in\ + module dependency graph" + where -- two versions, based on whether we simplify (thus run tidyProgram, + -- which returns a (CgGuts, ModDetails) pair, or not (in which case + -- we just have a ModGuts. + gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule + gutsToCoreModule (Left (cg, md)) = CoreModule { + cm_module = cg_module cg, cm_types = md_types md, + cm_imports = cg_dir_imps cg, cm_binds = cg_binds cg + } + gutsToCoreModule (Right mg) = CoreModule { + cm_module = mg_module mg, cm_types = mg_types mg, + cm_imports = moduleEnvKeys (mg_dir_imps mg), cm_binds = mg_binds mg + } + +-- --------------------------------------------------------------------------- -- Unloading unload :: HscEnv -> [Linkable] -> IO () @@ -877,13 +1274,15 @@ unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables #else LinkInMemory -> panic "unload: no interpreter" + -- urgh. avoid warnings: + hsc_env stable_linkables #endif - other -> return () + _other -> return () -- ----------------------------------------------------------------------------- --- checkStability -{- +{- | + Stability tells us which modules definitely do not need to be recompiled. There are two main reasons for having stability: @@ -898,7 +1297,7 @@ unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' The stability check is as follows. Both stableObject and stableBCO are used during the upsweep phase later. - ------------------- +@ stable m = stableObject m || stableBCO m stableObject m = @@ -909,21 +1308,23 @@ unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' stableBCO m = all stable (imports m) && date(BCO) > date(.hs) - ------------------- +@ These properties embody the following ideas: - if a module is stable, then: + - if it has been compiled in a previous pass (present in HPT) then it does not need to be compiled or re-linked. + - if it has not been compiled in a previous pass, then we only need to read its .hi file from disk and - link it to produce a ModDetails. + link it to produce a 'ModDetails'. - if a modules is not stable, we will definitely be at least - re-linking, and possibly re-compiling it during the upsweep. + re-linking, and possibly re-compiling it during the 'upsweep'. All non-stable modules can (and should) therefore be unlinked - before the upsweep. + before the 'upsweep'. - Note that objects are only considered stable if they only depend on other objects. We can't link object code against byte code. @@ -947,7 +1348,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 @@ -984,12 +1385,10 @@ 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 +-- | Prune the HomePackageTable +-- -- Before doing an upsweep, we can throw away: -- -- - For non-stable modules: @@ -1034,7 +1433,7 @@ findPartiallyCompletedCycles modsDone theGraph = chew theGraph where chew [] = [] - chew ((AcyclicSCC v):rest) = chew rest -- acyclic? not interesting. + chew ((AcyclicSCC _):rest) = chew rest -- acyclic? not interesting. chew ((CyclicSCC vs):rest) = let names_in_this_cycle = nub (map ms_mod vs) mods_in_this_cycle @@ -1048,80 +1447,98 @@ findPartiallyCompletedCycles modsDone theGraph else chewed_rest -- ----------------------------------------------------------------------------- --- The upsweep +-- | The upsweep +-- -- This is where we compile each module in the module graph, in a pass -- from the bottom to the top of the graph. - +-- -- There better had not be any cyclic groups here -- we check for them. upsweep - :: HscEnv -- Includes initially-empty HPT - -> 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) - -> IO (SuccessFlag, - HscEnv, -- With an updated HPT - [ModSummary]) -- Mods which succeeded - -upsweep hsc_env old_hpt stable_mods cleanup mods - = upsweep' hsc_env old_hpt stable_mods cleanup mods 1 (length mods) - -upsweep' hsc_env old_hpt stable_mods cleanup + :: GhcMonad m => + HscEnv -- ^ Includes initially-empty HPT + -> 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, + [ModSummary]) + -- ^ Returns: + -- + -- 1. A flag whether the complete upsweep was successful. + -- 2. The 'HscEnv' with an updated HPT + -- 3. A list of modules which succeeded loading. + +upsweep 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) + where + + upsweep' hsc_env _old_hpt done [] _ _ - = return (Succeeded, hsc_env, []) + = return (Succeeded, hsc_env, done) -upsweep' hsc_env old_hpt stable_mods cleanup + upsweep' hsc_env _old_hpt done (CyclicSCC ms:_) _ _ - = do fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms) - return (Failed, hsc_env, []) + = do liftIO $ fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms) + return (Failed, hsc_env, done) -upsweep' hsc_env old_hpt stable_mods cleanup + upsweep' hsc_env 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 = reportModuleCompilationResult (hsc_callbacks hsc_env) - mb_mod_info <- upsweep_mod hsc_env old_hpt stable_mods mod - mod_index nmods + mb_mod_info + <- handleSourceError + (\err -> do logger mod (Just err); return Nothing) $ do + mod_info <- upsweep_mod hsc_env old_hpt stable_mods + mod mod_index nmods + logger mod Nothing -- log warnings + return (Just mod_info) - cleanup -- Remove unwanted tmp files between compilations + liftIO cleanup -- Remove unwanted tmp files between compilations case mb_mod_info of - Nothing -> return (Failed, hsc_env, []) - Just mod_info -> do - { let this_mod = ms_mod_name mod + Nothing -> return (Failed, hsc_env, done) + Just mod_info -> do + let this_mod = ms_mod_name mod -- Add new info to hsc_env - hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info - hsc_env1 = hsc_env { hsc_HPT = hpt1 } + hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info + hsc_env1 = hsc_env { hsc_HPT = hpt1 } -- Space-saving: delete the old HPT entry -- for mod BUT if mod is a hs-boot -- node, don't delete it. For the -- interface, the HPT entry is probaby for the -- main Haskell source file. Deleting it - -- would force .. (what?? --SDM) - old_hpt1 | isBootSummary mod = old_hpt - | otherwise = delFromUFM old_hpt this_mod + -- would force the real module to be recompiled + -- every time. + old_hpt1 | isBootSummary mod = old_hpt + | otherwise = delFromUFM old_hpt this_mod - ; (restOK, hsc_env2, modOKs) - <- upsweep' hsc_env1 old_hpt1 stable_mods cleanup - mods (mod_index+1) nmods - ; return (restOK, hsc_env2, mod:modOKs) - } + done' = mod:done + -- fixup our HomePackageTable after we've finished compiling + -- a mutually-recursive loop. See reTypecheckLoop, below. + hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done' --- Compile a single module. Always produce a Linkable for it if + upsweep' hsc_env2 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 :: HscEnv +upsweep_mod :: GhcMonad m => + HscEnv -> HomePackageTable -> ([ModuleName],[ModuleName]) -> ModSummary -> Int -- index of module -> Int -- total number of modules - -> IO (Maybe HomeModInfo) -- Nothing => Failed + -> m HomeModInfo upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods = let @@ -1173,95 +1590,100 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods where iface = hm_iface hm_info - compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo) - compile_it = upsweep_compile hsc_env old_hpt this_mod_name - summary' mod_index nmods mb_old_iface + 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 - = upsweep_compile hsc_env old_hpt this_mod_name - summary' mod_index nmods Nothing + = compile hsc_env summary' mod_index nmods Nothing - in - case target of + -- 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 - _any + implies False _ = True + implies True x = x + + in + 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 -> - return old_hmi - -- object is stable, and we have an entry in the - -- old HPT: nothing to do - - | is_stable_obj, isNothing old_hmi -> do - linkable <- findObjectLinkable this_mod obj_fn - (expectJust "upseep1" 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 - return old_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 <- 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 - - --- Run hsc to compile a module -upsweep_compile hsc_env old_hpt this_mod summary - mod_index nmods - mb_old_iface - mb_old_linkable - = do - compresult <- compile hsc_env summary mb_old_linkable mb_old_iface - mod_index nmods + _otherwise -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod:" <+> ppr this_mod_name) + compile_it Nothing - case compresult of - -- Compilation failed. Compile may still have updated the PCS, tho. - CompErrs -> return Nothing - - -- Compilation "succeeded", and may or may not have returned a new - -- linkable (depending on whether compilation was actually performed - -- or not). - CompOK new_details new_iface new_linkable - -> do let new_info = HomeModInfo { hm_iface = new_iface, - hm_details = new_details, - hm_linkable = new_linkable } - return (Just new_info) -- Filter modules in the HPT @@ -1273,14 +1695,87 @@ retainInTopLevelEnvs keep_these hpt , isJust mb_mod_info ] -- --------------------------------------------------------------------------- +-- Typecheck module loops + +{- +See bug #930. This code fixes a long-standing bug in --make. The +problem is that when compiling the modules *inside* a loop, a data +type that is only defined at the top of the loop looks opaque; but +after the loop is done, the structure of the data type becomes +apparent. + +The difficulty is then that two different bits of code have +different notions of what the data type looks like. + +The idea is that after we compile a module which also has an .hs-boot +file, we re-generate the ModDetails for each of the modules that +depends on the .hs-boot file, so that everyone points to the proper +TyCons, Ids etc. defined by the real module, not the boot module. +Fortunately re-generating a ModDetails from a ModIface is easy: the +function TcIface.typecheckIface does exactly that. + +Picking the modules to re-typecheck is slightly tricky. Starting from +the module graph consisting of the modules that have already been +compiled, we reverse the edges (so they point from the imported module +to the importing module), and depth-first-search from the .hs-boot +node. This gives us all the modules that depend transitively on the +.hs-boot module, and those are exactly the modules that we need to +re-typecheck. + +Following this fix, GHC can compile itself with --make -O2. +-} + +reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv +reTypecheckLoop hsc_env ms graph + | not (isBootSummary ms) && + any (\m -> ms_mod m == this_mod && isBootSummary m) graph + = do + let mss = reachableBackwards (ms_mod_name ms) graph + non_boot = filter (not.isBootSummary) mss + debugTraceMsg (hsc_dflags hsc_env) 2 $ + text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot) + typecheckLoop hsc_env (map ms_mod_name non_boot) + | otherwise + = return hsc_env + where + this_mod = ms_mod ms + +typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv +typecheckLoop hsc_env mods = do + new_hpt <- + fixIO $ \new_hpt -> do + let new_hsc_env = hsc_env{ hsc_HPT = new_hpt } + mds <- initIfaceCheck new_hsc_env $ + mapM (typecheckIface . hm_iface) hmis + let new_hpt = addListToUFM old_hpt + (zip mods [ hmi{ hm_details = details } + | (hmi,details) <- zip hmis mds ]) + return new_hpt + return hsc_env{ hsc_HPT = new_hpt } + where + old_hpt = hsc_HPT hsc_env + hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods + +reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary] +reachableBackwards mod summaries + = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ] + where -- the rest just sets up the graph: + (graph, lookup_node) = moduleGraphNodes False summaries + root = expectJust "reachableBackwards" (lookup_node HsBootFile mod) + +-- --------------------------------------------------------------------------- -- Topological sort of the module graph +type SummaryNode = (ModSummary, Int, [Int]) + topSortModuleGraph - :: Bool -- Drop hi-boot nodes? (see below) + :: 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 @@ -1288,73 +1783,82 @@ 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 by cyclic - -topSortModuleGraph drop_hs_boot_nodes summaries Nothing - = stronglyConnComp (fst (moduleGraphNodes drop_hs_boot_nodes summaries)) -topSortModuleGraph drop_hs_boot_nodes summaries (Just mod) - = stronglyConnComp (map vertex_fn (reachable graph root)) - where - -- restrict the graph to just those modules reachable from - -- the specified module. We do this by building a graph with - -- the full set of nodes, and determining the reachable set from - -- the specified node. - (nodes, lookup_key) = moduleGraphNodes drop_hs_boot_nodes summaries - (graph, vertex_fn, key_fn) = graphFromEdges' nodes - root - | Just key <- lookup_key HsSrcFile mod, Just v <- key_fn key = v - | otherwise = throwDyn (ProgramError "module does not exist") +-- The resulting graph has no hi-boot nodes, but can be cyclic + +topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod + = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph + where + (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries + + initial_graph = case mb_root_mod of + Nothing -> graph + Just root_mod -> + -- restrict the graph to just those modules reachable from + -- the specified module. We do this by building a graph with + -- the full set of nodes, and determining the reachable set from + -- the specified node. + let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node + | otherwise = ghcError (ProgramError "module does not exist") + in graphFromEdgedVertices (seq root (reachableG graph root)) + +summaryNodeKey :: SummaryNode -> Int +summaryNodeKey (_, k, _) = k + +summaryNodeSummary :: SummaryNode -> ModSummary +summaryNodeSummary (s, _, _) = s moduleGraphNodes :: Bool -> [ModSummary] - -> ([(ModSummary, Int, [Int])], HscSource -> ModuleName -> Maybe Int) -moduleGraphNodes drop_hs_boot_nodes summaries = (nodes, lookup_key) - where - -- Drop hs-boot nodes by using HsSrcFile as the key - hs_boot_key | drop_hs_boot_nodes = HsSrcFile - | otherwise = HsBootFile - - -- We use integers as the keys for the SCC algorithm - nodes :: [(ModSummary, Int, [Int])] - nodes = [(s, expectJust "topSort" $ - lookup_key (ms_hsc_src s) (ms_mod_name s), - out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++ - out_edge_keys HsSrcFile (map unLoc (ms_imps s)) ++ - (-- see [boot-edges] below - if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile - then [] - else case lookup_key HsBootFile (ms_mod_name s) of - Nothing -> [] - Just k -> [k]) - ) - | s <- summaries - , not (isBootSummary s && drop_hs_boot_nodes) ] - -- Drop the hi-boot ones if told to do so - - -- [boot-edges] if this is a .hs and there is an equivalent - -- .hs-boot, add a link from the former to the latter. This - -- has the effect of detecting bogus cases where the .hs-boot - -- depends on the .hs, by introducing a cycle. Additionally, - -- it ensures that we will always process the .hs-boot before - -- the .hs, and so the HomePackageTable will always have the - -- most up to date information. - - key_map :: NodeMap Int - key_map = listToFM ([(moduleName (ms_mod s), ms_hsc_src s) - | s <- summaries] - `zip` [1..]) - - lookup_key :: HscSource -> ModuleName -> Maybe Int - lookup_key hs_src mod = lookupFM key_map (mod, hs_src) - - out_edge_keys :: HscSource -> [ModuleName] -> [Int] - out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms - -- If we want keep_hi_boot_nodes, then we do lookup_key with - -- the IsBootInterface parameter True; else False + -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode) +moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node) + where + numbered_summaries = zip summaries [1..] + + lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode + lookup_node hs_src mod = lookupFM node_map (mod, hs_src) + + lookup_key :: HscSource -> ModuleName -> Maybe Int + lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod) + + node_map :: NodeMap SummaryNode + node_map = listToFM [ ((moduleName (ms_mod s), ms_hsc_src s), node) + | node@(s, _, _) <- nodes ] + + -- We use integers as the keys for the SCC algorithm + nodes :: [SummaryNode] + nodes = [ (s, key, out_keys) + | (s, key) <- numbered_summaries + -- Drop the hi-boot ones if told to do so + , not (isBootSummary s && drop_hs_boot_nodes) + , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_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 [] + else case lookup_key HsBootFile (ms_mod_name s) of + Nothing -> [] + Just k -> [k]) ] + + -- [boot-edges] if this is a .hs and there is an equivalent + -- .hs-boot, add a link from the former to the latter. This + -- has the effect of detecting bogus cases where the .hs-boot + -- depends on the .hs, by introducing a cycle. Additionally, + -- it ensures that we will always process the .hs-boot before + -- the .hs, and so the HomePackageTable will always have the + -- most up to date information. + + -- Drop hs-boot nodes by using HsSrcFile as the key + hs_boot_key | drop_hs_boot_nodes = HsSrcFile + | otherwise = HsBootFile + + out_edge_keys :: HscSource -> [ModuleName] -> [Int] + out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms + -- If we want keep_hi_boot_nodes, then we do lookup_key with + -- the IsBootInterface parameter True; else False type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are @@ -1369,22 +1873,22 @@ mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries] nodeMapElts :: NodeMap a -> [a] nodeMapElts = eltsFM --- If there are {-# SOURCE #-} imports between strongly connected +-- | 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 :: DynFlags -> [SCC ModSummary] -> IO () -warnUnnecessarySourceImports dflags sccs = - printBagOfWarnings dflags (listToBag (concat (map (check.flattenSCC) sccs))) +warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m () +warnUnnecessarySourceImports sccs = + logWarnings (listToBag (concatMap (check.flattenSCC) sccs)) where check ms = let mods_in_this_cycle = map ms_mod_name ms in - [ warn m 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 :: ModSummary -> Located ModuleName -> WarnMsg - warn ms (L loc mod) = + warn :: Located ModuleName -> WarnMsg + warn (L loc mod) = mkPlainErrMsg loc - (ptext SLIT("Warning: {-# SOURCE #-} unnecessary in import of ") + (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ") <+> quotes (ppr mod)) ----------------------------------------------------------------------------- @@ -1402,67 +1906,72 @@ 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 :: HscEnv +downsweep :: GhcMonad m => + 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 - -> IO (Maybe [ModSummary]) + -> m [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 - = -- catch error messages and return them - handleDyn (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do + = 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 rootSummaries <- mapM getRootSummary roots let root_map = mkRootMap rootSummaries checkDuplicates root_map summs <- loop (concatMap msDeps rootSummaries) root_map - return (Just summs) + return summs where roots = hsc_targets hsc_env old_summary_map :: NodeMap ModSummary old_summary_map = mkNodeMap old_summaries - getRootSummary :: Target -> IO ModSummary - getRootSummary (Target (TargetFile file mb_phase) maybe_buf) - = do exists <- doesFileExist file + getRootSummary :: GhcMonad m => Target -> m 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 maybe_buf - else throwDyn $ mkPlainErrMsg noSrcSpan $ + then summariseFile hsc_env old_summaries file mb_phase + obj_allowed maybe_buf + else throwOneError $ mkPlainErrMsg noSrcSpan $ text "can't find file:" <+> text file - getRootSummary (Target (TargetModule modl) maybe_buf) + getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) = do maybe_summary <- summariseModule hsc_env old_summary_map False - (L rootLoc modl) maybe_buf excl_mods + (L rootLoc modl) obj_allowed + maybe_buf excl_mods case maybe_summary of Nothing -> packageModErr modl Just s -> return s - rootLoc = mkGeneralSrcSpan FSLIT("") + rootLoc = mkGeneralSrcSpan (fsLit "") -- In a root module, the filename is allowed to diverge from the module -- name, so we have to check that there aren't multiple root files -- defining the same module (otherwise the duplicates will be silently -- ignored, leading to confusing behaviour). - checkDuplicates :: NodeMap [ModSummary] -> IO () + checkDuplicates :: GhcMonad m => NodeMap [ModSummary] -> m () checkDuplicates root_map | allow_dup_roots = return () | null dup_roots = return () - | otherwise = multiRootsErr (head dup_roots) + | otherwise = liftIO $ multiRootsErr (head dup_roots) where dup_roots :: [[ModSummary]] -- Each at least of length 2 dup_roots = filterOut isSingleton (nodeMapElts root_map) - loop :: [(Located ModuleName,IsBootInterface)] + loop :: GhcMonad m => + [(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 - -> IO [ModSummary] + -> m [ModSummary] -- The result includes the worklist, except -- for those mentioned in the visited set loop [] done = return (concat (nodeMapElts done)) @@ -1471,13 +1980,14 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots = if isSingleton summs then loop ss done else - do { multiRootsErr summs; return [] } - | otherwise = do { mb_s <- summariseModule hsc_env old_summary_map - is_boot wanted_mod Nothing excl_mods - ; case mb_s of - Nothing -> loop ss done - Just s -> loop (msDeps s ++ ss) - (addToFM done key [s]) } + do { liftIO $ 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]) where key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile) @@ -1495,8 +2005,20 @@ 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, isNothing (ideclPkgQual i) ] + +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 @@ -1512,14 +2034,16 @@ msDeps s = -- resides. summariseFile - :: HscEnv + :: GhcMonad m => + HscEnv -> [ModSummary] -- old summaries -> FilePath -- source file name -> Maybe Phase -- start phase + -> Bool -- object code allowed? -> Maybe (StringBuffer,ClockTime) - -> IO ModSummary + -> m ModSummary -summariseFile hsc_env old_summaries file mb_phase maybe_buf +summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf -- we can use a cached summary if one is available and the -- source file hasn't changed, But we have to look up the summary -- by source file, rather than module name as we do in summarise. @@ -1530,7 +2054,7 @@ summariseFile hsc_env old_summaries file mb_phase maybe_buf -- return the cached summary if the source didn't change src_timestamp <- case maybe_buf of Just (_,t) -> return t - Nothing -> getModificationTime file + Nothing -> liftIO $ getModificationTime file -- The file exists; we checked in getRootSummary above. -- If it gets removed subsequently, then this -- getModificationTime may fail, but that's the right @@ -1538,7 +2062,11 @@ summariseFile hsc_env old_summaries file mb_phase maybe_buf if ms_hs_date old_summary == src_timestamp then do -- update the object-file timestamp - obj_timestamp <- getObjTimestamp location False + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then liftIO $ getObjTimestamp location False + else return Nothing return old_summary{ ms_obj_date = obj_timestamp } else new_summary @@ -1550,23 +2078,29 @@ summariseFile hsc_env old_summaries file mb_phase maybe_buf let dflags = hsc_dflags hsc_env (dflags', hspp_fn, buf) - <- preprocessFile dflags file mb_phase maybe_buf + <- preprocessFile hsc_env file mb_phase maybe_buf - (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn + (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file -- Make a ModLocation for this file - location <- mkHomeModLocation dflags mod_name file + location <- liftIO $ mkHomeModLocation dflags mod_name file -- Tell the Finder cache where it is, so that subsequent calls -- to findModule will find it, even if it's not on any search path - mod <- addHomeModuleToFinder hsc_env mod_name location + mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location src_timestamp <- case maybe_buf of Just (_,t) -> return t - Nothing -> getModificationTime file + Nothing -> liftIO $ getModificationTime file -- getMofificationTime may fail - obj_timestamp <- modificationTimeIfExists (ml_obj_file location) + -- when the user asks to load a source file by name, we only + -- use an object file if -fobject-code is on. See #1205. + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then liftIO $ modificationTimeIfExists (ml_obj_file location) + else return Nothing return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile, ms_location = location, @@ -1582,19 +2116,22 @@ findSummaryBySourceFile summaries file = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms], expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of [] -> Nothing - (x:xs) -> Just x + (x:_) -> Just x -- Summarise a module, and pick up source and timestamp. summariseModule - :: HscEnv + :: GhcMonad m => + 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 - -> IO (Maybe ModSummary) -- Its new summary + -> m (Maybe ModSummary) -- Its new summary -summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf excl_mods +summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) + obj_allowed maybe_buf excl_mods | wanted_mod `elem` excl_mods = return Nothing @@ -1610,11 +2147,11 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc case maybe_buf of Just (_,t) -> check_timestamp old_summary location src_fn t Nothing -> do - m <- System.IO.Error.try (getModificationTime src_fn) + m <- liftIO $ System.IO.Error.try (getModificationTime src_fn) case m of Right t -> check_timestamp old_summary location src_fn t Left e | isDoesNotExistError e -> find_it - | otherwise -> ioError e + | otherwise -> liftIO $ ioError e | otherwise = find_it where @@ -1625,7 +2162,11 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc check_timestamp old_summary location src_fn src_timestamp | ms_hs_date old_summary == src_timestamp = do -- update the object-file timestamp - obj_timestamp <- getObjTimestamp location is_boot + obj_timestamp <- liftIO $ + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then getObjTimestamp location is_boot + else return Nothing return (Just old_summary{ ms_obj_date = obj_timestamp }) | otherwise = -- source changed: re-summarise. @@ -1636,8 +2177,8 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc -- 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. - uncacheModule hsc_env wanted_mod - found <- findImportedModule hsc_env wanted_mod Nothing + liftIO $ uncacheModule hsc_env wanted_mod + found <- liftIO $ findImportedModule hsc_env wanted_mod Nothing case found of Found location mod | isJust (ml_hs_file location) -> @@ -1647,9 +2188,8 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc -- Drop external-pkg ASSERT(modulePackageId mod /= thisPackage dflags) return Nothing - where - err -> noModError dflags loc wanted_mod err + err -> liftIO $ noModError dflags loc wanted_mod err -- Not found just_found location mod = do @@ -1661,7 +2201,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc -- Check that it exists -- It might have been deleted since the Finder last found it - maybe_t <- modificationTimeIfExists src_fn + maybe_t <- liftIO $ modificationTimeIfExists src_fn case maybe_t of Nothing -> noHsFileErr loc src_fn Just t -> new_summary location' mod src_fn t @@ -1671,49 +2211,63 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc = do -- Preprocess the source file and get its imports -- The dflags' contains the OPTIONS pragmas - (dflags', hspp_fn, buf) <- preprocessFile dflags src_fn Nothing maybe_buf - (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn + (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf + (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn when (mod_name /= wanted_mod) $ - throwDyn $ mkPlainErrMsg mod_loc $ - text "file name does not match module name" - <+> quotes (ppr mod_name) + 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 <- getObjTimestamp location is_boot - - return (Just ( ModSummary { ms_mod = mod, - ms_hsc_src = hsc_src, - ms_location = location, - ms_hspp_file = hspp_fn, - ms_hspp_opts = dflags', - ms_hspp_buf = Just buf, - ms_srcimps = srcimps, - ms_imps = the_imps, - ms_hs_date = src_timestamp, - ms_obj_date = obj_timestamp })) - - + obj_timestamp <- liftIO $ + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then getObjTimestamp location is_boot + else return Nothing + + return (Just (ModSummary { ms_mod = mod, + ms_hsc_src = hsc_src, + ms_location = location, + ms_hspp_file = hspp_fn, + ms_hspp_opts = dflags', + ms_hspp_buf = Just buf, + ms_srcimps = srcimps, + ms_imps = the_imps, + ms_hs_date = src_timestamp, + ms_obj_date = obj_timestamp })) + + +getObjTimestamp :: ModLocation -> Bool -> IO (Maybe ClockTime) getObjTimestamp location is_boot = if is_boot then return Nothing else modificationTimeIfExists (ml_obj_file location) -preprocessFile :: DynFlags -> FilePath -> Maybe Phase -> Maybe (StringBuffer,ClockTime) - -> IO (DynFlags, FilePath, StringBuffer) -preprocessFile dflags src_fn mb_phase Nothing +preprocessFile :: GhcMonad m => + HscEnv + -> FilePath + -> Maybe Phase -- ^ Starting phase + -> Maybe (StringBuffer,ClockTime) + -> m (DynFlags, FilePath, StringBuffer) +preprocessFile hsc_env src_fn mb_phase Nothing = do - (dflags', hspp_fn) <- preprocess dflags (src_fn, mb_phase) - buf <- hGetStringBuffer hspp_fn + (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase) + buf <- liftIO $ hGetStringBuffer hspp_fn return (dflags', hspp_fn, buf) -preprocessFile dflags src_fn mb_phase (Just (buf, time)) +preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) = do + let dflags = hsc_dflags hsc_env -- case we bypass the preprocessing stage? let - local_opts = getOptions buf src_fn + local_opts = getOptions dflags buf src_fn -- - (dflags', errs) <- parseDynamicFlags dflags (map unLoc local_opts) + (dflags', leftovers, warns) + <- parseDynamicNoPackageFlags dflags local_opts + checkProcessArgsResult leftovers + handleFlagWarnings dflags' warns let needs_preprocessing @@ -1737,18 +2291,21 @@ preprocessFile dflags src_fn mb_phase (Just (buf, time)) noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab -- ToDo: we don't have a proper line number for this error noModError dflags loc wanted_mod err - = throwDyn $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err + = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err +noHsFileErr :: GhcMonad m => SrcSpan -> String -> m a noHsFileErr loc path - = throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path + = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path +packageModErr :: GhcMonad m => ModuleName -> m a packageModErr mod - = throwDyn $ mkPlainErrMsg noSrcSpan $ + = throwOneError $ mkPlainErrMsg noSrcSpan $ text "module" <+> quotes (ppr mod) <+> text "is a package module" multiRootsErr :: [ModSummary] -> IO () +multiRootsErr [] = panic "multiRootsErr" multiRootsErr summs@(summ1:_) - = throwDyn $ mkPlainErrMsg noSrcSpan $ + = throwOneError $ mkPlainErrMsg noSrcSpan $ text "module" <+> quotes (ppr mod) <+> text "is defined in multiple files:" <+> sep (map text files) @@ -1758,51 +2315,69 @@ multiRootsErr summs@(summ1:_) cyclicModuleErr :: [ModSummary] -> SDoc cyclicModuleErr ms - = hang (ptext SLIT("Module imports form a cycle for modules:")) + = hang (ptext (sLit "Module imports form a cycle for modules:")) 2 (vcat (map show_one ms)) where - show_one ms = sep [ show_mod (ms_hsc_src ms) (ms_mod ms), - nest 2 $ ptext SLIT("imports:") <+> - (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). -workingDirectoryChanged :: Session -> IO () -workingDirectoryChanged s = withSession s $ flushFinderCaches +-- +-- 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) -- ----------------------------------------------------------------------------- -- inspecting the session -- | Get the module dependency graph. -getModuleGraph :: Session -> IO ModuleGraph -- ToDo: DiGraph ModSummary -getModuleGraph s = withSession s (return . hsc_mod_graph) +getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary +getModuleGraph = liftM hsc_mod_graph getSession -isLoaded :: Session -> ModuleName -> IO Bool -isLoaded s m = withSession s $ \hsc_env -> +-- | 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 (dopt Opt_TemplateHaskell . ms_hspp_opts) ms + +-- | Return @True@ <==> module is loaded. +isLoaded :: GhcMonad m => ModuleName -> m Bool +isLoaded m = withSession $ \hsc_env -> return $! isJust (lookupUFM (hsc_HPT hsc_env) m) -getBindings :: Session -> IO [TyThing] -getBindings s = withSession s $ \hsc_env -> +-- | Return the bindings for the current interactive session. +getBindings :: GhcMonad m => m [TyThing] +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 :: Session -> IO PrintUnqualified -getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC) +getPrintUnqual :: GhcMonad m => m PrintUnqualified +getPrintUnqual = withSession $ \hsc_env -> + return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env)) -- | Container for information about a 'Module'. data ModuleInfo = ModuleInfo { @@ -1819,23 +2394,23 @@ data ModuleInfo = ModuleInfo { -- to package modules too. -- | Request information about a loaded 'Module' -getModuleInfo :: Session -> Module -> IO (Maybe ModuleInfo) -getModuleInfo s mdl = withSession s $ \hsc_env -> do +getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X +getModuleInfo mdl = withSession $ \hsc_env -> do let mg = hsc_mod_graph hsc_env if mdl `elem` map ms_mod mg - then getHomeModuleInfo hsc_env (moduleName mdl) + then liftIO $ getHomeModuleInfo hsc_env (moduleName mdl) else do {- if isHomeModule (hsc_dflags hsc_env) mdl then return Nothing - else -} getPackageModuleInfo hsc_env mdl + else -} liftIO $ getPackageModuleInfo hsc_env mdl -- getPackageModuleInfo will attempt to find the interface, so -- we don't want to call it for a home module, just in case there -- was a problem loading the module and the interface doesn't -- exist... hence the isHomeModule test here. (ToDo: reinstate) getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) -getPackageModuleInfo hsc_env mdl = do #ifdef GHCI +getPackageModuleInfo hsc_env mdl = do (_msgs, mb_avails) <- getModuleExports hsc_env mdl case mb_avails of Nothing -> return Nothing @@ -1855,10 +2430,12 @@ getPackageModuleInfo hsc_env mdl = do minf_modBreaks = emptyModBreaks })) #else +getPackageModuleInfo _hsc_env _mdl = do -- bogusly different for non-GHCI (ToDo) return Nothing #endif +getHomeModuleInfo :: HscEnv -> ModuleName -> IO (Maybe ModuleInfo) getHomeModuleInfo hsc_env mdl = case lookupUFM (hsc_HPT hsc_env) mdl of Nothing -> return Nothing @@ -1870,7 +2447,7 @@ getHomeModuleInfo hsc_env mdl = minf_rdr_env = mi_globals $! hm_iface hmi, minf_instances = md_insts details #ifdef GHCI - ,minf_modBreaks = md_modBreaks details + ,minf_modBreaks = getModBreaks hmi #endif })) @@ -1893,35 +2470,67 @@ modInfoInstances = minf_instances modInfoIsExportedName :: ModuleInfo -> Name -> Bool modInfoIsExportedName minf name = elemNameSet name (minf_exports minf) -modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified -modInfoPrintUnqualified minf = fmap mkPrintUnqualified (minf_rdr_env minf) +mkPrintUnqualifiedForModule :: GhcMonad m => + ModuleInfo + -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X +mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do + return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf)) -modInfoLookupName :: Session -> ModuleInfo -> Name -> IO (Maybe TyThing) -modInfoLookupName s minf name = withSession s $ \hsc_env -> do +modInfoLookupName :: GhcMonad m => + ModuleInfo -> Name + -> m (Maybe TyThing) -- XXX: returns a Maybe X +modInfoLookupName minf name = withSession $ \hsc_env -> do case lookupTypeEnv (minf_type_env minf) name of Just tyThing -> return (Just tyThing) Nothing -> do - eps <- readIORef (hsc_EPS hsc_env) + eps <- liftIO $ readIORef (hsc_EPS hsc_env) return $! lookupType (hsc_dflags hsc_env) (hsc_HPT hsc_env) (eps_PTE eps) name #ifdef GHCI +modInfoModBreaks :: ModuleInfo -> ModBreaks modInfoModBreaks = minf_modBreaks #endif isDictonaryId :: Id -> Bool isDictonaryId id - = case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau } + = case tcSplitSigmaTy (idType id) of { (_tvs, _theta, tau) -> isDictTy tau } -- | Looks up a global name: that is, any top-level name in any -- visible module. Unlike 'lookupName', lookupGlobalName does not use -- the interactive context, and therefore does not require a preceding -- 'setContext'. -lookupGlobalName :: Session -> Name -> IO (Maybe TyThing) -lookupGlobalName s name = withSession s $ \hsc_env -> do - eps <- readIORef (hsc_EPS hsc_env) - return $! lookupType (hsc_dflags hsc_env) - (hsc_HPT hsc_env) (eps_PTE eps) name +lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing) +lookupGlobalName name = withSession $ \hsc_env -> do + 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 +getGRE :: GhcMonad m => m GlobalRdrEnv +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 = UFM.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 @@ -1949,42 +2558,158 @@ pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a)) -- :browse will use either lm_toplev or inspect lm_interface, depending -- on whether the module is interpreted or not. --- This is for reconstructing refactored source code --- Calls the lexer repeatedly. --- ToDo: add comment tokens to token stream -getTokenStream :: Session -> Module -> IO [Located Token] #endif +-- Extract the filename, stringbuffer content and dynflags associed to a module +-- +-- XXX: Explain pre-conditions +getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags) +getModuleSourceAndFlags mod = do + m <- getModSummary (moduleName mod) + case ml_hs_file $ ms_location m of + Nothing -> throw $ mkApiErr (text "No source available for module " <+> ppr mod) + Just sourceFile -> do + source <- liftIO $ hGetStringBuffer sourceFile + return (sourceFile, source, ms_hspp_opts m) + + +-- | Return module source as token stream, including comments. +-- +-- The module must be in the module graph and its source must be available. +-- Throws a 'HscTypes.SourceError' on parse error. +getTokenStream :: GhcMonad m => Module -> m [Located Token] +getTokenStream mod = do + (sourceFile, source, flags) <- getModuleSourceAndFlags mod + 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) + +-- | Give even more information on the source than 'getTokenStream' +-- This function allows reconstructing the source completely with +-- 'showRichTokenStream'. +getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)] +getRichTokenStream mod = do + (sourceFile, source, flags) <- getModuleSourceAndFlags mod + 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) + +-- | Given a source location and a StringBuffer corresponding to this +-- location, return a rich token stream with the source associated to the +-- tokens. +addSourceToTokens :: SrcLoc -> StringBuffer -> [Located Token] + -> [(Located Token, String)] +addSourceToTokens _ _ [] = [] +addSourceToTokens loc buf (t@(L span _) : ts) + | not (isGoodSrcSpan span) = (t,"") : addSourceToTokens loc buf ts + | otherwise = (t,str) : addSourceToTokens newLoc newBuf ts + where + (newLoc, newBuf, str) = go "" loc buf + start = srcSpanStart span + end = srcSpanEnd span + go acc loc buf | loc < start = go acc nLoc nBuf + | start <= loc && loc < end = go (ch:acc) nLoc nBuf + | otherwise = (loc, buf, reverse acc) + where (ch, nBuf) = nextChar buf + nLoc = advanceSrcLoc loc ch + + +-- | Take a rich token stream such as produced from 'getRichTokenStream' and +-- return source code almost identical to the original code (except for +-- insignificant whitespace.) +showRichTokenStream :: [(Located Token, String)] -> String +showRichTokenStream ts = go startLoc ts "" + where sourceFile = srcSpanFile (getLoc . fst . head $ ts) + startLoc = mkSrcLoc sourceFile 1 1 + go _ [] = id + go loc ((L span _, str):ts) + | not (isGoodSrcSpan span) = go loc ts + | locLine == tokLine = ((replicate (tokCol - locCol) ' ') ++) + . (str ++) + . go tokEnd ts + | otherwise = ((replicate (tokLine - locLine) '\n') ++) + . ((replicate tokCol ' ') ++) + . (str ++) + . go tokEnd ts + where (locLine, locCol) = (srcLocLine loc, srcLocCol loc) + (tokLine, tokCol) = (srcSpanStartLine span, srcSpanStartCol span) + tokEnd = srcSpanEnd span + -- ----------------------------------------------------------------------------- -- Interactive evaluation -- | Takes a 'ModuleName' and possibly a 'PackageId', and consults the -- filesystem and package database to find the corresponding 'Module', -- using the algorithm that is used for an @import@ declaration. -findModule :: Session -> ModuleName -> Maybe PackageId -> IO Module -findModule s mod_name maybe_pkg = withSession s $ \hsc_env -> - findModule' hsc_env mod_name maybe_pkg - -findModule' hsc_env mod_name maybe_pkg = - 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 -> throwDyn (CmdLineError (showSDoc $ - text "module" <+> pprModule m <+> - text "is not loaded")) - err -> let msg = cannotFindModule dflags mod_name err in - throwDyn (CmdLineError (showSDoc msg)) +findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module +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 :: Session -> History -> IO SrcSpan -getHistorySpan sess h = withSession sess $ \hsc_env -> +getHistorySpan :: GhcMonad m => History -> m SrcSpan +getHistorySpan h = withSession $ \hsc_env -> return$ InteractiveEval.getHistorySpan hsc_env h -#endif \ No newline at end of file + +obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term +obtainTermFromVal bound force ty a = + withSession $ \hsc_env -> + liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a + +obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term +obtainTermFromId bound force id = + withSession $ \hsc_env -> + liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id + +#endif