Session,
defaultErrorHandler,
defaultCleanupHandler,
- init,
+ init, initFromArgs,
newSession,
-- * Flags and settings
- DynFlags(..), DynFlag(..), GhcMode(..), HscTarget(..), dopt,
+ DynFlags(..), DynFlag(..), Severity(..), GhcMode(..), HscTarget(..), dopt,
parseDynamicFlags,
+ initPackages,
getSessionDynFlags,
setSessionDynFlags,
- setMsgHandler,
-- * Targets
- Target(..),
+ Target(..), TargetId(..), Phase,
setTargets,
getTargets,
addTarget,
+ removeTarget,
guessTarget,
- -- * Loading/compiling the program
+ -- * Loading\/compiling the program
depanal,
- load, SuccessFlag(..), -- also does depanal
+ load, LoadHowMuch(..), SuccessFlag(..), -- also does depanal
workingDirectoryChanged,
+ checkModule, CheckedModule(..),
+ TypecheckedSource, ParsedSource, RenamedSource,
-- * Inspecting the module structure of the program
- ModuleGraph, ModSummary(..),
+ ModuleGraph, ModSummary(..), ModLocation(..),
getModuleGraph,
+ isLoaded,
topSortModuleGraph,
+ -- * Inspecting modules
+ ModuleInfo,
+ getModuleInfo,
+ modInfoTyThings,
+ modInfoTopLevelScope,
+ modInfoPrintUnqualified,
+ modInfoExports,
+ modInfoInstances,
+ modInfoIsExportedName,
+ modInfoLookupName,
+ lookupGlobalName,
+
+ -- * Printing
+ PrintUnqualified, alwaysQualify,
+
-- * Interactive evaluation
getBindings, getPrintUnqual,
#ifdef GHCI
setContext, getContext,
+ getNamesInScope,
+ getRdrNamesInScope,
moduleIsInterpreted,
- getInfo, GetInfoResult,
+ getInfo,
exprType,
typeKind,
- lookupName,
+ parseName,
RunResult(..),
runStmt,
- browseModule,
showModule,
compileExpr, HValue,
+ lookupName,
#endif
-- * Abstract syntax elements
+
+ -- ** Modules
Module, mkModule, pprModule,
- Type, dropForAlls,
+
+ -- ** Names
+ Name,
+ nameModule, nameParent_maybe, pprParenSymName, nameSrcLoc,
+ NamedThing(..),
+ RdrName(Qual,Unqual),
+
+ -- ** Identifiers
+ Id, idType,
+ isImplicitId, isDeadBinder,
+ isExportedId, isLocalId, isGlobalId,
+ isRecordSelector,
+ isPrimOpId, isFCallId, isClassOpId_maybe,
+ isDataConWorkId, idDataCon,
+ isBottomingId, isDictonaryId,
+ recordSelectorFieldLabel,
+
+ -- ** Type constructors
+ TyCon,
+ tyConTyVars, tyConDataCons, tyConArity,
+ isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
+ synTyConDefn, synTyConRhs,
+
+ -- ** Type variables
+ TyVar,
+ alphaTyVars,
+
+ -- ** Data constructors
+ DataCon,
+ dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
+ dataConIsInfix, isVanillaDataCon,
+ dataConStrictMarks,
+ StrictnessMark(..), isMarkedStrict,
+
+ -- ** Classes
+ Class,
+ classMethods, classSCTheta, classTvsFds,
+ pprFundeps,
+
+ -- ** Instances
+ Instance,
+ instanceDFunId, pprInstance, pprInstanceHdr,
+
+ -- ** Types and Kinds
+ Type, dropForAlls, splitForAllTys, funResultTy, pprParendType,
Kind,
- Name, Id, TyCon, Class, DataCon,
+ PredType,
+ ThetaType, pprThetaArrow,
+
+ -- ** Entities
TyThing(..),
- idType,
- -- used by DriverMkDepend:
+ -- ** Syntax
+ module HsSyn, -- ToDo: remove extraneous bits
+
+ -- ** Fixities
+ FixityDirection(..),
+ defaultFixity, maxPrecedence,
+ negateFixity,
+ compareFixity,
+
+ -- ** Source locations
+ SrcLoc, pprDefnLoc,
+
+ -- * Exceptions
+ GhcException(..), showGhcException,
+
+ -- * Miscellaneous
sessionHscEnv,
cyclicModuleErr,
) where
{-
ToDo:
- * return error messages rather than printing them.
- * inline bits of HscMain here to simplify layering: hscGetInfo,
- hscTcExpr, hscStmt.
- * implement second argument to load.
+ * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
* we need to expose DynFlags, so should parseDynamicFlags really be
part of this interface?
* what StaticFlags should we expose, if any?
#ifdef GHCI
import qualified Linker
import Linker ( HValue, extendLinkEnv )
-import NameEnv ( lookupNameEnv )
-import TcRnDriver ( mkExportEnv, getModuleContents )
-import RdrName ( GlobalRdrEnv, plusGlobalRdrEnv )
-import HscMain ( hscGetInfo, GetInfoResult,
- hscStmt, hscTcExpr, hscKcType )
+import TcRnDriver ( tcRnLookupRdrName, tcRnGetInfo,
+ tcRnLookupName, getModuleExports )
+import RdrName ( plusGlobalRdrEnv, Provenance(..),
+ ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
+ emptyGlobalRdrEnv, mkGlobalRdrEnv )
+import HscMain ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType )
import Type ( tidyType )
import VarEnv ( emptyTidyEnv )
import GHC.Exts ( unsafeCoerce# )
-import IfaceSyn ( IfaceDecl )
#endif
-import Type ( Kind, Type, dropForAlls )
-import Id ( Id, idType )
-import TyCon ( TyCon )
-import Class ( Class )
-import DataCon ( DataCon )
-import Name ( Name )
+import Packages ( initPackages )
+import NameSet ( NameSet, nameSetToList, elemNameSet )
+import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..),
+ globalRdrEnvElts )
+import HsSyn
+import Type ( Kind, Type, dropForAlls, PredType, ThetaType,
+ pprThetaArrow, pprParendType, splitForAllTys,
+ funResultTy )
+import Id ( Id, idType, isImplicitId, isDeadBinder,
+ isExportedId, isLocalId, isGlobalId,
+ isRecordSelector, recordSelectorFieldLabel,
+ isPrimOpId, isFCallId, isClassOpId_maybe,
+ isDataConWorkId, idDataCon,
+ isBottomingId )
+import Var ( TyVar )
+import TysPrim ( alphaTyVars )
+import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon,
+ isPrimTyCon, isFunTyCon, tyConArity,
+ tyConTyVars, tyConDataCons, synTyConDefn, synTyConRhs )
+import Class ( Class, classSCTheta, classTvsFds, classMethods )
+import FunDeps ( pprFundeps )
+import DataCon ( DataCon, dataConWrapId, dataConSig, dataConTyCon,
+ dataConFieldLabels, dataConStrictMarks,
+ dataConIsInfix, isVanillaDataCon )
+import Name ( Name, nameModule, NamedThing(..), nameParent_maybe,
+ nameSrcLoc, nameOccName )
+import OccName ( parenSymOcc )
import NameEnv ( nameEnvElts )
-import DriverPipeline ( preprocess, compile, CompResult(..), link )
-import DriverPhases ( isHaskellSrcFilename )
+import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr )
+import SrcLoc
+import DriverPipeline
+import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase )
import GetImports ( getImports )
import Packages ( isHomePackage )
import Finder
-import HscMain ( newHscEnv )
+import HscMain ( newHscEnv, hscFileCheck, HscResult(..) )
import HscTypes
import DynFlags
import StaticFlags
import Module
import FiniteMap
import Panic
-import Digraph ( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs )
-import ErrUtils ( showPass )
+import Digraph
+import Bag ( unitBag )
+import ErrUtils ( Severity(..), showPass, fatalErrorMsg, debugTraceMsg,
+ mkPlainErrMsg, printBagOfErrors, printErrorsAndWarnings )
import qualified ErrUtils
import Util
-import StringBuffer ( hGetStringBuffer )
+import StringBuffer ( StringBuffer, hGetStringBuffer )
import Outputable
import SysTools ( cleanTempFilesExcept )
-import BasicTypes ( SuccessFlag(..), succeeded )
-import Maybes ( orElse, expectJust, mapCatMaybes )
-
-import Directory ( getModificationTime, doesFileExist )
-import Maybe ( isJust, fromJust )
-import List ( partition, nub )
-import Monad ( unless, when, foldM )
-import System ( exitWith, ExitCode(..) )
-import EXCEPTION as Exception hiding (handle)
-import DATA_IOREF
-import IO
+import BasicTypes
+import TcType ( tcSplitSigmaTy, isDictTy )
+import Maybes ( expectJust, mapCatMaybes )
+
+import Control.Concurrent
+import System.Directory ( getModificationTime, doesFileExist )
+import Data.Maybe ( isJust, isNothing, fromJust )
+import Data.List ( partition, nub )
+import qualified Data.List as List
+import Control.Monad ( unless, when )
+import System.Exit ( exitWith, ExitCode(..) )
+import System.Time ( ClockTime )
+import Control.Exception as Exception hiding (handle)
+import Data.IORef
+import System.IO
+import System.IO.Error ( isDoesNotExistError )
+import System.IO.Unsafe ( unsafePerformIO )
import Prelude hiding (init)
+#if __GLASGOW_HASKELL__ < 600
+import System.IO as System.IO.Error ( try )
+#else
+import System.IO.Error ( try )
+#endif
+
-- -----------------------------------------------------------------------------
-- Exception handlers
-- 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 :: IO a -> IO a
-defaultErrorHandler inner =
+defaultErrorHandler :: DynFlags -> IO a -> IO 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 _ -> hPutStrLn stderr (show exception)
+ IOException _ ->
+ fatalErrorMsg dflags (text (show exception))
AsyncException StackOverflow ->
- hPutStrLn stderr "stack overflow: use +RTS -K<size> to increase it"
- _other -> hPutStr stderr (show (Panic (show exception)))
+ fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
+ _other ->
+ fatalErrorMsg dflags (text (show (Panic (show exception))))
exitWith (ExitFailure 1)
) $
- -- all error messages are propagated as exceptions
+ -- 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
hFlush stdout
case dyn of
PhaseFailed _ code -> exitWith code
Interrupted -> exitWith (ExitFailure 1)
- _ -> do hPutStrLn stderr (show (dyn :: GhcException))
+ _ -> do fatalErrorMsg dflags (text (show (dyn :: GhcException)))
exitWith (ExitFailure 1)
) $
inner
-- | Initialises GHC. This must be done /once/ only. Takes the
--- command-line arguments. All command-line arguments which aren't
--- understood by GHC will be returned.
+-- TopDir path without the '-B' prefix.
-init :: [String] -> IO [String]
-init args = do
+init :: Maybe String -> IO ()
+init mbMinusB = do
-- catch ^C
+ main_thread <- myThreadId
+ putMVar interruptTargetThread [main_thread]
installSignalHandlers
- -- Grab the -B option if there is one
- let (minusB_args, argv1) = partition (prefixMatch "-B") args
- dflags0 <- initSysTools minusB_args defaultDynFlags
+ dflags0 <- initSysTools mbMinusB defaultDynFlags
writeIORef v_initDynFlags dflags0
- -- Parse the static flags
- argv2 <- parseStaticFlags argv1
- return argv2
+-- | Initialises GHC. This must be done /once/ only. Takes the
+-- command-line arguments. All command-line arguments which aren't
+-- understood by GHC will be returned.
+
+initFromArgs :: [String] -> IO [String]
+initFromArgs args
+ = do init mbMinusB
+ return argv1
+ where -- Grab the -B option if there is one
+ (minusB_args, argv1) = partition (prefixMatch "-B") args
+ mbMinusB | null minusB_args
+ = Nothing
+ | otherwise
+ = Just (drop 2 (last minusB_args))
GLOBAL_VAR(v_initDynFlags, error "initDynFlags", DynFlags)
-- stores the DynFlags between the call to init and subsequent
-- | Starts a new session. A session consists of a set of loaded
-- modules, a set of options (DynFlags), and an interactive context.
--- ToDo: GhcMode should say "keep typechecked code" and/or "keep renamed
+-- ToDo: GhcMode should say "keep typechecked code" and\/or "keep renamed
-- code".
newSession :: GhcMode -> IO Session
newSession mode = do
setSessionDynFlags :: Session -> DynFlags -> IO ()
setSessionDynFlags s dflags = modifySession s (\h -> h{ hsc_dflags = dflags })
--- | Messages during compilation (eg. warnings and progress messages)
--- are reported using this callback. By default, these messages are
--- printed to stderr.
-setMsgHandler :: (String -> IO ()) -> IO ()
-setMsgHandler = ErrUtils.setMsgHandler
+-- | 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 ->
+ let dflags = hsc_dflags env
+ mod_graph = hsc_mod_graph env
+ mainModuleSrcPath, guessedName :: 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
+ in
+ case outputFile dflags of
+ Just _ -> env
+ Nothing -> env { hsc_dflags = dflags { outputFile = guessedName } }
-- -----------------------------------------------------------------------------
-- Targets
-- | 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
+-- 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 })
getTargets :: Session -> IO [Target]
getTargets s = withSession s (return . hsc_targets)
--- Add another target, or update an existing target with new content.
+-- | Add another target
addTarget :: Session -> Target -> IO ()
addTarget s target
= modifySession s (\h -> h{ hsc_targets = target : hsc_targets h })
--- Remove a target
--- removeTarget :: Session -> Module -> IO ()
+-- | Remove a target
+removeTarget :: Session -> TargetId -> IO ()
+removeTarget s target_id
+ = modifySession s (\h -> h{ hsc_targets = filter (hsc_targets h) })
+ where
+ filter targets = [ t | t@(Target id _) <- targets, id /= target_id ]
-- Attempts to guess what Target a string refers to. This function implements
-- the --make/GHCi command-line syntax for filenames:
-- then use that
-- - otherwise interpret the string as a module name
--
-guessTarget :: String -> IO Target
-guessTarget file
+guessTarget :: String -> Maybe Phase -> IO Target
+guessTarget file (Just phase)
+ = return (Target (TargetFile file (Just phase)) Nothing)
+guessTarget file Nothing
| isHaskellSrcFilename file
- = return (Target (TargetFile file) Nothing)
+ = return (Target (TargetFile file Nothing) Nothing)
| otherwise
= do exists <- doesFileExist hs_file
- if exists then return (Target (TargetFile hs_file) Nothing) else do
+ if exists
+ then return (Target (TargetFile hs_file Nothing) Nothing)
+ else do
exists <- doesFileExist lhs_file
- if exists then return (Target (TargetFile lhs_file) Nothing) else do
+ if exists
+ then return (Target (TargetFile lhs_file Nothing) Nothing)
+ else do
return (Target (TargetModule (mkModule file)) Nothing)
where
- hs_file = file ++ ".hs"
- lhs_file = file ++ ".lhs"
+ hs_file = file `joinFileExt` "hs"
+ lhs_file = file `joinFileExt` "lhs"
-- -----------------------------------------------------------------------------
-- Loading the program
+-- Perform a dependency analysis starting from the current targets
+-- and update the session with the new module graph.
+depanal :: Session -> [Module] -> Bool -> IO (Maybe ModuleGraph)
+depanal (Session ref) excluded_mods allow_dup_roots = do
+ hsc_env <- readIORef ref
+ let
+ dflags = hsc_dflags hsc_env
+ gmode = ghcMode (hsc_dflags hsc_env)
+ targets = hsc_targets hsc_env
+ old_graph = hsc_mod_graph hsc_env
+
+ showPass dflags "Chasing dependencies"
+ when (gmode == BatchCompile) $
+ debugTraceMsg dflags 1 (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.
type Errors = [String]
-{-
data ErrMsg = ErrMsg {
errMsgSeverity :: Severity, -- warning, error, etc.
errMsgSpans :: [SrcSpan],
}
-}
--- Perform a dependency analysis starting from the current targets
--- and update the session with the new module graph.
-depanal :: Session -> [Module] -> IO ()
-depanal (Session ref) excluded_mods = do
- hsc_env <- readIORef ref
- let
- dflags = hsc_dflags hsc_env
- gmode = ghcMode (hsc_dflags hsc_env)
- targets = hsc_targets hsc_env
- old_graph = hsc_mod_graph hsc_env
-
- showPass dflags "Chasing dependencies"
- when (verbosity dflags >= 1 && gmode == BatchCompile) $
- hPutStrLn stderr (showSDoc (hcat [
- text "Chasing modules from: ",
- hcat (punctuate comma (map pprTarget targets))]))
-
- graph <- downsweep hsc_env old_graph excluded_mods
- writeIORef ref hsc_env{ hsc_mod_graph=graph }
-
+data LoadHowMuch
+ = LoadAllTargets
+ | LoadUpTo Module
+ | LoadDependenciesOf Module
-- | 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 -> Maybe Module -> IO SuccessFlag
-load s@(Session ref) maybe_mod{-ToDo-}
+load :: Session -> LoadHowMuch -> IO SuccessFlag
+load s@(Session ref) how_much
= do
- -- dependency analysis first
- depanal s []
-
+ -- 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 -> load2 s how_much mod_graph
+ Nothing -> return Failed
+
+load2 s@(Session ref) how_much mod_graph = do
+ guessOutputFile s
hsc_env <- readIORef ref
let hpt1 = hsc_HPT hsc_env
let dflags = hsc_dflags hsc_env
- let mod_graph = hsc_mod_graph hsc_env
-
- let ghci_mode = ghcMode (hsc_dflags hsc_env) -- this never changes
- let verb = verbosity dflags
+ let ghci_mode = ghcMode dflags -- this never changes
-- The "bad" boot modules are the ones for which we have
-- B.hs-boot in the module graph, but no B.hs
-- The downsweep should have ensured this does not happen
-- (see msDeps)
let all_home_mods = [ms_mod s | s <- mod_graph, not (isBootSummary s)]
+#ifdef DEBUG
bad_boot_mods = [s | s <- mod_graph, isBootSummary s,
not (ms_mod s `elem` all_home_mods)]
+#endif
ASSERT( null bad_boot_mods ) return ()
- -- Topologically sort the module graph
- -- mg2 should be cycle free; but it includes hi-boot ModSummary nodes
- let mg2 :: [SCC ModSummary]
- mg2 = topSortModuleGraph False mod_graph
-
-- 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
-- upsweep, and for removing from hpt all the modules
-- not in strict downwards closure, during calls to compile.
let mg2_with_srcimps :: [SCC ModSummary]
- mg2_with_srcimps = topSortModuleGraph True mod_graph
-
- -- Sort out which linkables we wish to keep in the unlinked image.
- -- See getValidLinkables below for details.
- (valid_old_linkables, new_linkables)
- <- getValidLinkables ghci_mode (hptLinkables hpt1)
- all_home_mods mg2_with_srcimps
-
- -- putStrLn (showSDoc (vcat [ppr valid_old_linkables, ppr new_linkables]))
-
- -- The new_linkables are .o files we found on the disk, presumably
- -- as a result of a GHC run "on the side". So we'd better forget
- -- everything we know abouut those modules!
- let old_hpt = delModuleEnvList hpt1 (map linkableModule new_linkables)
-
- -- When (verb >= 2) $
- -- putStrLn (showSDoc (text "Valid linkables:"
- -- <+> ppr valid_linkables))
-
- -- Figure out a stable set of modules which can be retained
- -- the top level envs, to avoid upsweeping them. Goes to a
- -- bit of trouble to avoid upsweeping module cycles.
- --
- -- Construct a set S of stable modules like this:
- -- Travel upwards, over the sccified graph. For each scc
- -- of modules ms, add ms to S only if:
- -- 1. All home imports of ms are either in ms or S
- -- 2. A valid old linkable exists for each module in ms
-
- -- mg2_with_srcimps has no hi-boot nodes,
- -- and hence neither does stable_mods
- stable_summaries <- preUpsweep valid_old_linkables
- all_home_mods [] mg2_with_srcimps
- let stable_mods = map ms_mod stable_summaries
- stable_linkables = filter (\m -> linkableModule m `elem` stable_mods)
- valid_old_linkables
-
- stable_hpt = filterModuleEnv is_stable_hm hpt1
- is_stable_hm hm_info = mi_module (hm_iface hm_info) `elem` stable_mods
-
- upsweep_these
- = filter (\scc -> any (`notElem` stable_mods)
- (map ms_mod (flattenSCC scc)))
- mg2
-
- when (verb >= 2) $
- hPutStrLn stderr (showSDoc (text "Stable modules:"
- <+> sep (map (text.moduleUserString) stable_mods)))
+ mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
+
+ -- check the stability property for each module.
+ stable_mods@(stable_obj,stable_bco)
+ | BatchCompile <- ghci_mode = ([],[])
+ | otherwise = checkStability hpt1 mg2_with_srcimps all_home_mods
+
+ -- prune bits of the HPT which are definitely redundant now,
+ -- to save space.
+ pruned_hpt = pruneHomePackageTable hpt1
+ (flattenSCCs mg2_with_srcimps)
+ stable_mods
+
+ evaluate pruned_hpt
+
+ 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.
+ let stable_linkables = [ linkable
+ | m <- stable_obj++stable_bco,
+ Just hmi <- [lookupModuleEnv pruned_hpt m],
+ Just linkable <- [hm_linkable hmi] ]
unload hsc_env stable_linkables
- -- We can now glom together our linkable sets
- let valid_linkables = valid_old_linkables ++ new_linkables
-
-- We could at this point detect cycles which aren't broken by
-- a source-import, and complain immediately, but it seems better
-- to let upsweep_mods do this, so at least some useful work gets
-- Now do the upsweep, calling compile for each module in
-- turn. Final result is version 3 of everything.
+ -- Topologically sort the module graph, this time including hi-boot
+ -- nodes, and possibly just including the portion of the graph
+ -- reachable from the module specified in the 2nd argument to load.
+ -- This graph should be cycle-free.
+ -- If we're restricting the upsweep to a portion of the graph, we
+ -- also want to retain everything that is still stable.
+ let full_mg :: [SCC ModSummary]
+ full_mg = topSortModuleGraph False mod_graph Nothing
+
+ maybe_top_mod = case how_much of
+ LoadUpTo m -> Just m
+ LoadDependenciesOf m -> Just m
+ _ -> Nothing
+
+ partial_mg0 :: [SCC ModSummary]
+ partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod
+
+ -- LoadDependenciesOf m: we want the upsweep to stop just
+ -- short of the specified module (unless the specified module
+ -- is stable).
+ partial_mg
+ | LoadDependenciesOf mod <- how_much
+ = ASSERT( case last partial_mg0 of
+ AcyclicSCC ms -> ms_mod ms == mod; _ -> False )
+ List.init partial_mg0
+ | otherwise
+ = partial_mg0
+
+ stable_mg =
+ [ AcyclicSCC ms
+ | AcyclicSCC ms <- full_mg,
+ ms_mod ms `elem` stable_obj++stable_bco,
+ ms_mod ms `notElem` [ ms_mod ms' |
+ AcyclicSCC ms' <- partial_mg ] ]
+
+ mg = stable_mg ++ partial_mg
+
-- clean up between compilations
let cleanup = cleanTempFilesExcept dflags
- (ppFilesFromSummaries (flattenSCCs mg2))
+ (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps))
- (upsweep_ok, hsc_env3, modsUpswept)
- <- upsweep_mods (hsc_env { hsc_HPT = stable_hpt })
- (old_hpt, valid_linkables)
- cleanup upsweep_these
-
- -- At this point, modsUpswept and newLis should have the same
- -- length, so there is one new (or old) linkable for each
- -- mod which was processed (passed to compile).
+ (upsweep_ok, hsc_env1, modsUpswept)
+ <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable })
+ pruned_hpt stable_mods cleanup mg
-- Make modsDone be the summaries for each home module now
-- available; this should equal the domain of hpt3.
- -- (NOT STRICTLY TRUE if an interactive session was started
- -- with some object on disk ???)
-- Get in in a roughly top .. bottom order (hence reverse).
- let modsDone = reverse modsUpswept ++ stable_summaries
+ let modsDone = reverse modsUpswept
-- Try and do linking in some form, depending on whether the
-- upsweep was completely or only partially successful.
then
-- Easy; just relink it all.
- do when (verb >= 2) $
- hPutStrLn stderr "Upsweep completely successful."
+ do debugTraceMsg dflags 2 (text "Upsweep completely successful.")
-- Clean up after ourselves
cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
--
let ofile = outputFile dflags
let no_hs_main = dopt Opt_NoHsMain dflags
- let mb_main_mod = mainModIs dflags
let
- main_mod = mb_main_mod `orElse` "Main"
- a_root_is_Main
- = any ((==main_mod).moduleUserString.ms_mod)
- mod_graph
+ main_mod = mainModIs dflags
+ a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
do_linking = a_root_is_Main || no_hs_main
- when (ghci_mode == BatchCompile && isJust ofile && not do_linking
- && verb > 0) $
- hPutStrLn stderr ("Warning: output was redirected with -o, " ++
- "but no output will be generated\n" ++
- "because there is no " ++ main_mod ++ " module.")
+ when (ghci_mode == BatchCompile && isJust ofile && not do_linking) $
+ debugTraceMsg dflags 1 (text ("Warning: output was redirected with -o, " ++
+ "but no output will be generated\n" ++
+ "because there is no " ++ moduleString main_mod ++ " module."))
-- link everything together
- linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env3)
+ linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env1)
- let hsc_env4 = hsc_env3{ hsc_mod_graph = modsDone }
- loadFinish Succeeded linkresult ref hsc_env4
+ loadFinish Succeeded linkresult ref 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 when (verb >= 2) $
- hPutStrLn stderr "Upsweep partially successful."
+ do debugTraceMsg dflags 2 (text "Upsweep partially successful.")
let modsDone_names
= map ms_mod modsDone
modsDone
let hpt4 = retainInTopLevelEnvs (map ms_mod mods_to_keep)
- (hsc_HPT hsc_env3)
+ (hsc_HPT hsc_env1)
-- Clean up after ourselves
cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep)
+ -- there should be no Nothings where linkables should be, now
+ ASSERT(all (isJust.hm_linkable)
+ (moduleEnvElts (hsc_HPT hsc_env))) do
+
-- Link everything together
linkresult <- link ghci_mode dflags False hpt4
- let hsc_env4 = hsc_env3{ hsc_mod_graph = mods_to_keep,
- hsc_HPT = hpt4 }
+ let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 }
loadFinish Failed linkresult ref hsc_env4
-- Finish up after a load.
= do writeIORef ref $! hsc_env{ hsc_IC = emptyInteractiveContext }
return all_ok
+
-- Forget the current program, but retain the persistent info in HscEnv
discardProg :: HscEnv -> HscEnv
discardProg hsc_env
-- source file, but that doesn't do any harm.
ppFilesFromSummaries summaries = [ fn | Just fn <- map ms_hspp_file summaries ]
------------------------------------------------------------------------------
+-- -----------------------------------------------------------------------------
+-- Check module
+
+data CheckedModule =
+ CheckedModule { parsedSource :: ParsedSource,
+ renamedSource :: Maybe RenamedSource,
+ typecheckedSource :: Maybe TypecheckedSource,
+ checkedModuleInfo :: Maybe ModuleInfo
+ }
+ -- 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.
+
+type ParsedSource = Located (HsModule RdrName)
+type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name])
+type TypecheckedSource = LHsBinds Id
+
+-- NOTE:
+-- - things that aren't in the output of the typechecker right now:
+-- - the export list
+-- - the imports
+-- - type signatures
+-- - type/data/newtype declarations
+-- - class declarations
+-- - instances
+-- - extra things in the typechecker's output:
+-- - 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' loads all the dependencies of the specified
+-- module in the Session, and then attempts to typecheck the module. If
+-- successful, it returns the abstract syntax for the module.
+checkModule :: Session -> Module -> IO (Maybe CheckedModule)
+checkModule session@(Session ref) mod = do
+ -- load up the dependencies first
+ r <- load session (LoadDependenciesOf mod)
+ if (failed r) then return Nothing else do
+
+ -- now parse & typecheck the module
+ hsc_env <- readIORef ref
+ let mg = hsc_mod_graph hsc_env
+ case [ ms | ms <- mg, ms_mod ms == mod ] of
+ [] -> return Nothing
+ (ms:_) -> do
+ -- Add in the OPTIONS from the source file This is nasty:
+ -- we've done this once already, in the compilation manager
+ -- It might be better to cache the flags in the
+ -- ml_hspp_file field, say
+ let dflags0 = hsc_dflags hsc_env
+ hspp_buf = expectJust "GHC.checkModule" (ms_hspp_buf ms)
+ filename = fromJust (ml_hs_file (ms_location ms))
+ opts = getOptionsFromStringBuffer hspp_buf filename
+ (dflags1,leftovers) <- parseDynamicFlags dflags0 (map snd opts)
+ if (not (null leftovers))
+ then do printErrorsAndWarnings dflags1 (optionsErrorMsgs leftovers opts filename)
+ return Nothing
+ else do
+
+ r <- hscFileCheck hsc_env{hsc_dflags=dflags1} ms
+ case r of
+ HscFail ->
+ return Nothing
+ HscChecked parsed renamed Nothing ->
+ return (Just (CheckedModule {
+ parsedSource = parsed,
+ renamedSource = renamed,
+ typecheckedSource = Nothing,
+ checkedModuleInfo = Nothing }))
+ HscChecked parsed renamed
+ (Just (tc_binds, rdr_env, details)) -> do
+ let minf = ModuleInfo {
+ minf_type_env = md_types details,
+ minf_exports = md_exports details,
+ minf_rdr_env = Just rdr_env,
+ minf_instances = md_insts details
+ }
+ return (Just (CheckedModule {
+ parsedSource = parsed,
+ renamedSource = renamed,
+ typecheckedSource = Just tc_binds,
+ checkedModuleInfo = Just minf }))
+ _other ->
+ panic "checkModule"
+
+-- ---------------------------------------------------------------------------
-- Unloading
unload :: HscEnv -> [Linkable] -> IO ()
unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
= case ghcMode (hsc_dflags hsc_env) of
- BatchCompile -> return ()
+ BatchCompile -> return ()
+ JustTypecheck -> return ()
#ifdef GHCI
Interactive -> Linker.unload (hsc_dflags hsc_env) stable_linkables
#else
Interactive -> panic "unload: no interpreter"
#endif
other -> panic "unload: strange mode"
-
------------------------------------------------------------------------------
--- getValidLinkables
--- For each module (or SCC of modules), we take:
---
--- - an on-disk linkable, if this is the first time around and one
--- is available.
---
--- - the old linkable, otherwise (and if one is available).
---
--- and we throw away the linkable if it is older than the source file.
--- In interactive mode, we also ignore the on-disk linkables unless
--- all of the dependents of this SCC also have on-disk linkables (we
--- can't have dynamically loaded objects that depend on interpreted
--- modules in GHCi).
---
--- If a module has a valid linkable, then it may be STABLE (see below),
--- and it is classified as SOURCE UNCHANGED for the purposes of calling
--- compile.
---
--- ToDo: this pass could be merged with the preUpsweep.
---
--- ****************
--- CAREFUL! This pass operates on the cyclic version of
--- the module graph (topSortModuleGraph True), whereas the upsweep operates on
--- the non-cyclic (topSortModuleGraph False) version of the graph.
--- ****************
-
-getValidLinkables
- :: GhcMode
- -> [Linkable] -- old linkables
- -> [Module] -- all home modules
- -> [SCC ModSummary] -- all modules in the program, dependency order
- -> IO ( [Linkable], -- still-valid linkables
- [Linkable] -- new linkables we just found on the disk
- -- presumably generated by separate run of ghc
- )
-
-getValidLinkables mode old_linkables all_home_mods module_graph
- = do { -- Process the SCCs in bottom-to-top order
- -- (foldM works left-to-right)
- ls <- foldM (getValidLinkablesSCC mode old_linkables all_home_mods)
- [] module_graph
- ; return (partition_it ls [] []) }
- where
- partition_it [] valid new = (valid,new)
- partition_it ((l,b):ls) valid new
- | b = partition_it ls valid (l:new)
- | otherwise = partition_it ls (l:valid) new
-
-
-getValidLinkablesSCC
- :: GhcMode
- -> [Linkable] -- old linkables
- -> [Module] -- all home modules
- -> [(Linkable,Bool)]
- -> SCC ModSummary
- -> IO [(Linkable,Bool)]
-
-getValidLinkablesSCC mode old_linkables all_home_mods new_linkables scc0
- = let
- scc = flattenSCC scc0
- scc_names = map ms_mod scc
- home_module m = m `elem` all_home_mods && m `notElem` scc_names
- scc_allhomeimps = nub (filter home_module (concatMap ms_imps scc))
- -- NB. ms_imps, not ms_allimps above. We don't want to
- -- force a module's SOURCE imports to be already compiled for
- -- its object linkable to be valid.
-
- -- The new_linkables is only the *valid* linkables below here
- has_object m = case findModuleLinkable_maybe (map fst new_linkables) m of
- Nothing -> False
- Just l -> isObjectLinkable l
-
- objects_allowed = mode == BatchCompile || all has_object scc_allhomeimps
- in do
-
- new_linkables'
- <- foldM (getValidLinkable old_linkables objects_allowed) [] scc
-
- -- since an scc can contain only all objects or no objects at all,
- -- we have to check whether we got all objects or not, and re-do
- -- the linkable check if not.
- new_linkables' <-
- if objects_allowed
- && not (all isObjectLinkable (map fst new_linkables'))
- then foldM (getValidLinkable old_linkables False) [] scc
- else return new_linkables'
-
- return (new_linkables ++ new_linkables')
-
-
-getValidLinkable :: [Linkable] -> Bool -> [(Linkable,Bool)] -> ModSummary
- -> IO [(Linkable,Bool)]
- -- True <=> linkable is new; i.e. freshly discovered on the disk
- -- presumably generated 'on the side'
- -- by a separate GHC run
-getValidLinkable old_linkables objects_allowed new_linkables summary
- -- 'objects_allowed' says whether we permit this module to
- -- have a .o-file linkable. We only permit it if all the
- -- modules it depends on also have .o files; a .o file can't
- -- link to a bytecode module
- = do let mod_name = ms_mod summary
-
- maybe_disk_linkable
- <- if (not objects_allowed)
- then return Nothing
-
- else findLinkable mod_name (ms_location summary)
-
- let old_linkable = findModuleLinkable_maybe old_linkables mod_name
-
- new_linkables' =
- case (old_linkable, maybe_disk_linkable) of
- (Nothing, Nothing) -> []
-
- -- new object linkable just appeared
- (Nothing, Just l) -> up_to_date l True
-
- (Just l, Nothing)
- | isObjectLinkable l -> []
- -- object linkable disappeared! In case we need to
- -- relink the module, disregard the old linkable and
- -- just interpret the module from now on.
- | otherwise -> up_to_date l False
- -- old byte code linkable
-
- (Just l, Just l')
- | not (isObjectLinkable l) -> up_to_date l False
- -- if the previous linkable was interpreted, then we
- -- ignore a newly compiled version, because the version
- -- numbers in the interface file will be out-of-sync with
- -- our internal ones.
- | linkableTime l' > linkableTime l -> up_to_date l' True
- | linkableTime l' == linkableTime l -> up_to_date l False
- | otherwise -> []
- -- on-disk linkable has been replaced by an older one!
- -- again, disregard the previous one.
-
- up_to_date l b
- | linkableTime l < ms_hs_date summary = []
- | otherwise = [(l,b)]
- -- why '<' rather than '<=' above? If the filesystem stores
+-- -----------------------------------------------------------------------------
+-- checkStability
+
+{-
+ Stability tells us which modules definitely do not need to be recompiled.
+ There are two main reasons for having stability:
+
+ - avoid doing a complete upsweep of the module graph in GHCi when
+ modules near the bottom of the tree have not changed.
+
+ - to tell GHCi when it can load object code: we can only load object code
+ for a module when we also load object code fo all of the imports of the
+ module. So we need to know that we will definitely not be recompiling
+ any of these modules, and we can use the object code.
+
+ NB. stability is of no importance to BatchCompile at all, only Interactive.
+ (ToDo: what about JustTypecheck?)
+
+ 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 =
+ all stableObject (imports m)
+ && old linkable does not exist, or is == on-disk .o
+ && date(on-disk .o) > date(.hs)
+
+ stableBCO m =
+ all stable (imports m)
+ && date(BCO) > date(.hs)
+ -------------------
+
+ These properties embody the following ideas:
+
+ - if a module is stable:
+ - 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.
+
+ - if a modules is not stable, we will definitely be at least
+ re-linking, and possibly re-compiling it during the upsweep.
+ All non-stable modules can (and should) therefore be unlinked
+ 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.
+-}
+
+checkStability
+ :: HomePackageTable -- HPT from last compilation
+ -> [SCC ModSummary] -- current module graph (cyclic)
+ -> [Module] -- all home modules
+ -> ([Module], -- stableObject
+ [Module]) -- stableBCO
+
+checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
+ where
+ checkSCC (stable_obj, stable_bco) scc0
+ | stableObjects = (scc_mods ++ stable_obj, stable_bco)
+ | stableBCOs = (stable_obj, scc_mods ++ stable_bco)
+ | otherwise = (stable_obj, stable_bco)
+ where
+ scc = flattenSCC scc0
+ scc_mods = map ms_mod scc
+ home_module m = m `elem` all_home_mods && m `notElem` scc_mods
+
+ scc_allimps = nub (filter home_module (concatMap ms_allimps scc))
+ -- all imports outside the current SCC, but in the home pkg
+
+ stable_obj_imps = map (`elem` stable_obj) scc_allimps
+ stable_bco_imps = map (`elem` stable_bco) scc_allimps
+
+ stableObjects =
+ and stable_obj_imps
+ && all object_ok scc
+
+ stableBCOs =
+ and (zipWith (||) stable_obj_imps stable_bco_imps)
+ && all bco_ok scc
+
+ object_ok ms
+ | Just t <- ms_obj_date ms = t >= ms_hs_date ms
+ && same_as_prev t
+ | otherwise = False
+ where
+ same_as_prev t = case lookupModuleEnv hpt (ms_mod ms) of
+ Just hmi | Just l <- hm_linkable hmi
+ -> isObjectLinkable l && t == linkableTime l
+ _other -> True
+ -- why '>=' rather than '>' above? If the filesystem stores
-- times to the nearset second, we may occasionally find that
-- the object & source have the same modification time,
-- especially if the source was automatically generated
-- and compiled. Using >= is slightly unsafe, but it matches
-- make's behaviour.
- return (new_linkables' ++ new_linkables)
+ bco_ok ms
+ = case lookupModuleEnv hpt (ms_mod ms) of
+ Just hmi | Just l <- hm_linkable hmi ->
+ not (isObjectLinkable l) &&
+ linkableTime l >= ms_hs_date ms
+ _other -> False
+ms_allimps :: ModSummary -> [Module]
+ms_allimps ms = map unLoc (ms_srcimps ms ++ ms_imps ms)
-hptLinkables :: HomePackageTable -> [Linkable]
--- Get all the linkables from the home package table, one for each module
--- Once the HPT is up to date, these are the ones we should link
-hptLinkables hpt = map hm_linkable (moduleEnvElts hpt)
+-- -----------------------------------------------------------------------------
+-- Prune the HomePackageTable
+-- Before doing an upsweep, we can throw away:
+--
+-- - For non-stable modules:
+-- - all ModDetails, all linked code
+-- - all unlinked code that is out of date with respect to
+-- the source file
+--
+-- This is VERY IMPORTANT otherwise we'll end up requiring 2x the
+-- space at the end of the upsweep, because the topmost ModDetails of the
+-- old HPT holds on to the entire type environment from the previous
+-- compilation.
+
+pruneHomePackageTable
+ :: HomePackageTable
+ -> [ModSummary]
+ -> ([Module],[Module])
+ -> HomePackageTable
+
+pruneHomePackageTable hpt summ (stable_obj, stable_bco)
+ = mapModuleEnv prune hpt
+ where prune hmi
+ | is_stable modl = hmi'
+ | otherwise = hmi'{ hm_details = emptyModDetails }
+ where
+ modl = mi_module (hm_iface hmi)
+ hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms
+ = hmi{ hm_linkable = Nothing }
+ | otherwise
+ = hmi
+ where ms = expectJust "prune" (lookupModuleEnv ms_map modl)
------------------------------------------------------------------------------
--- Do a pre-upsweep without use of "compile", to establish a
--- (downward-closed) set of stable modules for which we won't call compile.
-
--- a stable module:
--- * has a valid linkable (see getValidLinkables above)
--- * depends only on stable modules
--- * has an interface in the HPT (interactive mode only)
-
-preUpsweep :: [Linkable] -- new valid linkables
- -> [Module] -- names of all mods encountered in downsweep
- -> [ModSummary] -- accumulating stable modules
- -> [SCC ModSummary] -- scc-ified mod graph, including src imps
- -> IO [ModSummary] -- stable modules
-
-preUpsweep valid_lis all_home_mods stable [] = return stable
-preUpsweep valid_lis all_home_mods stable (scc0:sccs)
- = do let scc = flattenSCC scc0
- scc_allhomeimps :: [Module]
- scc_allhomeimps
- = nub (filter (`elem` all_home_mods) (concatMap ms_allimps scc))
- all_imports_in_scc_or_stable
- = all in_stable_or_scc scc_allhomeimps
- scc_mods = map ms_mod scc
- stable_names = scc_mods ++ map ms_mod stable
- in_stable_or_scc m = m `elem` stable_names
-
- -- now we check for valid linkables: each module in the SCC must
- -- have a valid linkable (see getValidLinkables above).
- has_valid_linkable scc_mod
- = isJust (findModuleLinkable_maybe valid_lis scc_mod)
-
- scc_is_stable = all_imports_in_scc_or_stable
- && all has_valid_linkable scc_mods
-
- if scc_is_stable
- then preUpsweep valid_lis all_home_mods (scc ++ stable) sccs
- else preUpsweep valid_lis all_home_mods stable sccs
+ ms_map = mkModuleEnv [(ms_mod ms, ms) | ms <- summ]
-ms_allimps :: ModSummary -> [Module]
-ms_allimps ms = ms_srcimps ms ++ ms_imps ms
+ is_stable m = m `elem` stable_obj || m `elem` stable_bco
+
+-- -----------------------------------------------------------------------------
-- Return (names of) all those in modsDone who are part of a cycle
-- as defined by theGraph.
then mods_in_this_cycle ++ chewed_rest
else chewed_rest
+-- -----------------------------------------------------------------------------
+-- 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.
--- Compile multiple modules, stopping as soon as an error appears.
-- There better had not be any cyclic groups here -- we check for them.
-upsweep_mods :: HscEnv -- Includes initially-empty HPT
- -> (HomePackageTable, [Linkable]) -- HPT and valid linkables from last time round
- -> 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_mods hsc_env oldUI cleanup
- []
+
+upsweep
+ :: HscEnv -- Includes initially-empty HPT
+ -> HomePackageTable -- HPT from last time round (pruned)
+ -> ([Module],[Module]) -- 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
+ [] _ _
= return (Succeeded, hsc_env, [])
-upsweep_mods hsc_env oldUI cleanup
- (CyclicSCC ms:_)
- = do hPutStrLn stderr (showSDoc (cyclicModuleErr ms))
+upsweep' hsc_env old_hpt stable_mods cleanup
+ (CyclicSCC ms:_) _ _
+ = do fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms)
return (Failed, hsc_env, [])
-upsweep_mods hsc_env oldUI@(old_hpt, old_linkables) cleanup
- (AcyclicSCC mod:mods)
+upsweep' hsc_env old_hpt stable_mods cleanup
+ (AcyclicSCC mod:mods) mod_index nmods
= do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
-- show (map (moduleUserString.moduleName.mi_module.hm_iface)
-- (moduleEnvElts (hsc_HPT hsc_env)))
- mb_mod_info <- upsweep_mod hsc_env oldUI mod
+ mb_mod_info <- upsweep_mod hsc_env old_hpt stable_mods mod
+ mod_index nmods
cleanup -- Remove unwanted tmp files between compilations
{ let this_mod = ms_mod mod
-- Add new info to hsc_env
- hpt1 = extendModuleEnv (hsc_HPT hsc_env) this_mod mod_info
+ hpt1 = extendModuleEnv (hsc_HPT hsc_env)
+ this_mod mod_info
hsc_env1 = hsc_env { hsc_HPT = hpt1 }
- -- Space-saving: delete the old HPT entry and
- -- linkable for mod BUT if mod is a hs-boot
- -- node, don't delete it For the linkable this
- -- is dead right: the linkable relates only to
- -- the main Haskell source file. For the
+
+ -- 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)
- oldUI1 | isBootSummary mod = oldUI
- | otherwise
- = (delModuleEnv old_hpt this_mod,
- delModuleLinkable old_linkables this_mod)
+ old_hpt1 | isBootSummary mod = old_hpt
+ | otherwise = delModuleEnv old_hpt this_mod
- ; (restOK, hsc_env2, modOKs) <- upsweep_mods hsc_env1 oldUI1 cleanup mods
- ; return (restOK, hsc_env2, mod:modOKs) }
+ ; (restOK, hsc_env2, modOKs)
+ <- upsweep' hsc_env1 old_hpt1 stable_mods cleanup
+ mods (mod_index+1) nmods
+ ; return (restOK, hsc_env2, mod:modOKs)
+ }
-- Compile a single module. Always produce a Linkable for it if
-- successful. If no compilation happened, return the old Linkable.
upsweep_mod :: HscEnv
- -> (HomePackageTable, UnlinkedImage)
+ -> HomePackageTable
+ -> ([Module],[Module])
-> ModSummary
+ -> Int -- index of module
+ -> Int -- total number of modules
-> IO (Maybe HomeModInfo) -- Nothing => Failed
-upsweep_mod hsc_env (old_hpt, old_linkables) summary
+upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
= do
- let this_mod = ms_mod summary
-
+ let
+ this_mod = ms_mod summary
+ mb_obj_date = ms_obj_date summary
+ obj_fn = ml_obj_file (ms_location summary)
+ hs_date = ms_hs_date summary
+
+ compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo)
+ compile_it = upsweep_compile hsc_env old_hpt this_mod
+ summary mod_index nmods
+
+ case ghcMode (hsc_dflags hsc_env) of
+ BatchCompile ->
+ case () of
+ -- Batch-compilating is easy: just check whether we have
+ -- an up-to-date object file. If we do, then the compiler
+ -- needs to do a recompilation check.
+ _ | Just obj_date <- mb_obj_date, obj_date >= hs_date -> do
+ linkable <-
+ findObjectLinkable this_mod obj_fn obj_date
+ compile_it (Just linkable)
+
+ | otherwise ->
+ compile_it Nothing
+
+ interactive ->
+ case () of
+ _ | 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.
+
+ | 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.
+ where
+ is_stable_obj = this_mod `elem` stable_obj
+ is_stable_bco = this_mod `elem` stable_bco
+
+ old_hmi = lookupModuleEnv old_hpt this_mod
+
+-- Run hsc to compile a module
+upsweep_compile hsc_env old_hpt this_mod summary
+ mod_index nmods
+ mb_old_linkable = do
+ let
-- The old interface is ok if it's in the old HPT
-- a) we're compiling a source file, and the old HPT
- -- entry is for a source file
+ -- entry is for a source file
-- b) we're compiling a hs-boot file
-- Case (b) allows an hs-boot file to get the interface of its
-- real source file on the second iteration of the compilation
-- manager, but that does no harm. Otherwise the hs-boot file
-- will always be recompiled
- mb_old_iface
+ mb_old_iface
= case lookupModuleEnv old_hpt this_mod of
Nothing -> Nothing
Just hm_info | isBootSummary summary -> Just iface
where
iface = hm_iface hm_info
- maybe_old_linkable = findModuleLinkable_maybe old_linkables this_mod
- source_unchanged = isJust maybe_old_linkable
-
- old_linkable = expectJust "upsweep_mod:old_linkable" maybe_old_linkable
+ compresult <- compile hsc_env summary mb_old_linkable mb_old_iface
+ mod_index nmods
- have_object
- | Just l <- maybe_old_linkable, isObjectLinkable l = True
- | otherwise = False
+ case compresult of
+ -- Compilation failed. Compile may still have updated the PCS, tho.
+ CompErrs -> return Nothing
- compresult <- compile hsc_env summary source_unchanged have_object mb_old_iface
-
- case compresult of
-
- -- 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 maybe_new_linkable
- -> do let
- new_linkable = maybe_new_linkable `orElse` old_linkable
- new_info = HomeModInfo { hm_iface = new_iface,
+ -- 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)
- -- Compilation failed. Compile may still have updated the PCS, tho.
- CompErrs -> return Nothing
-- Filter modules in the HPT
retainInTopLevelEnvs :: [Module] -> HomePackageTable -> HomePackageTable
retainInTopLevelEnvs keep_these hpt
- = mkModuleEnv [ (mod, fromJust mb_mod_info)
+ = mkModuleEnv [ (mod, expectJust "retain" mb_mod_info)
| mod <- keep_these
, let mb_mod_info = lookupModuleEnv hpt mod
, isJust mb_mod_info ]
topSortModuleGraph
:: Bool -- Drop hi-boot nodes? (see below)
-> [ModSummary]
+ -> Maybe Module
-> [SCC ModSummary]
-- 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
+-- the top.
--
-- Drop hi-boot nodes (first boolean arg)?
--
-- 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
- = stronglyConnComp nodes
+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")
+
+moduleGraphNodes :: Bool -> [ModSummary]
+ -> ([(ModSummary, Int, [Int])], HscSource -> Module -> 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
-- We use integers as the keys for the SCC algorithm
nodes :: [(ModSummary, Int, [Int])]
- nodes = [(s, fromJust (lookup_key (ms_hsc_src s) (ms_mod s)),
- out_edge_keys hs_boot_key (ms_srcimps s) ++
- out_edge_keys HsSrcFile (ms_imps s) )
+ nodes = [(s, expectJust "topSort" (lookup_key (ms_hsc_src s) (ms_mod s)),
+ out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++
+ out_edge_keys HsSrcFile (map unLoc (ms_imps s)) )
| s <- summaries
, not (isBootSummary s && drop_hs_boot_nodes) ]
-- Drop the hi-boot ones if told to do so
msKey :: ModSummary -> NodeKey
msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (mod,boot)
-emptyNodeMap :: NodeMap a
-emptyNodeMap = emptyFM
-
mkNodeMap :: [ModSummary] -> NodeMap ModSummary
mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries]
nodeMapElts :: NodeMap a -> [a]
nodeMapElts = eltsFM
--- -----------------------------------------------------------------
--- The unlinked image
---
--- The compilation manager keeps a list of compiled, but as-yet unlinked
--- binaries (byte code or object code). Even when it links bytecode
--- it keeps the unlinked version so it can re-link it later without
--- recompiling.
-
-type UnlinkedImage = [Linkable] -- the unlinked images (should be a set, really)
-
-findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
-findModuleLinkable_maybe lis mod
- = case [LM time nm us | LM time nm us <- lis, nm == mod] of
- [] -> Nothing
- [li] -> Just li
- many -> pprPanic "findModuleLinkable" (ppr mod)
-
-delModuleLinkable :: [Linkable] -> Module -> [Linkable]
-delModuleLinkable ls mod = [ l | l@(LM _ nm _) <- ls, nm /= mod ]
-
-----------------------------------------------------------------------------
-- Downsweep (dependency analysis)
downsweep :: HscEnv
-> [ModSummary] -- Old summaries
- -> [Module] -- Ignore dependencies on these; treat them as
- -- if they were package modules
- -> IO [ModSummary]
-downsweep hsc_env old_summaries excl_mods
- = do rootSummaries <- mapM getRootSummary roots
- checkDuplicates rootSummaries
- loop (concatMap msDeps rootSummaries)
- (mkNodeMap rootSummaries)
+ -> [Module] -- 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])
+ -- 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
+ rootSummaries <- mapM getRootSummary roots
+ let root_map = mkRootMap rootSummaries
+ checkDuplicates root_map
+ summs <- loop (concatMap msDeps rootSummaries) root_map
+ return (Just summs)
where
- dflags = hsc_dflags hsc_env
roots = hsc_targets hsc_env
old_summary_map :: NodeMap ModSummary
old_summary_map = mkNodeMap old_summaries
getRootSummary :: Target -> IO ModSummary
- getRootSummary (Target (TargetFile file) maybe_buf)
+ getRootSummary (Target (TargetFile file mb_phase) maybe_buf)
= do exists <- doesFileExist file
- if exists then summariseFile hsc_env file else do
- throwDyn (CmdLineError ("can't find file: " ++ file))
+ if exists
+ then summariseFile hsc_env old_summaries file mb_phase maybe_buf
+ else throwDyn $ mkPlainErrMsg noSrcSpan $
+ text "can't find file:" <+> text file
getRootSummary (Target (TargetModule modl) maybe_buf)
- = do maybe_summary <- summarise hsc_env emptyNodeMap Nothing False
- modl excl_mods
+ = do maybe_summary <- summariseModule hsc_env old_summary_map False
+ (L rootLoc modl) maybe_buf excl_mods
case maybe_summary of
Nothing -> packageModErr modl
Just s -> return s
+ rootLoc = mkGeneralSrcSpan FSLIT("<command line>")
+
-- 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 :: [ModSummary] -> IO ()
- checkDuplicates summaries = mapM_ check summaries
- where check summ =
- case dups of
- [] -> return ()
- [_one] -> return ()
- many -> multiRootsErr modl many
- where modl = ms_mod summ
- dups =
- [ fromJust (ml_hs_file (ms_location summ'))
- | summ' <- summaries, ms_mod summ' == modl ]
-
- loop :: [(FilePath,Module,IsBootInterface)]
+ checkDuplicates :: NodeMap [ModSummary] -> IO ()
+ checkDuplicates root_map
+ | allow_dup_roots = return ()
+ | null dup_roots = return ()
+ | otherwise = multiRootsErr (head dup_roots)
+ where
+ dup_roots :: [[ModSummary]] -- Each at least of length 2
+ dup_roots = filterOut isSingleton (nodeMapElts root_map)
+
+ loop :: [(Located Module,IsBootInterface)]
-- Work list: process these modules
- -> NodeMap ModSummary
- -- Visited set
+ -> 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]
-- The result includes the worklist, except
-- for those mentioned in the visited set
- loop [] done = return (nodeMapElts done)
- loop ((cur_path, wanted_mod, is_boot) : ss) done
- | key `elemFM` done = loop ss done
- | otherwise = do { mb_s <- summarise hsc_env old_summary_map
- (Just cur_path) is_boot
- wanted_mod excl_mods
+ loop [] done = return (concat (nodeMapElts done))
+ loop ((wanted_mod, is_boot) : ss) done
+ | Just summs <- lookupFM done key
+ = 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) }
+ (addToFM done key [s]) }
where
- key = (wanted_mod, if is_boot then HsBootFile else HsSrcFile)
+ key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)
+
+mkRootMap :: [ModSummary] -> NodeMap [ModSummary]
+mkRootMap summaries = addListToFM_C (++) emptyFM
+ [ (msKey s, [s]) | s <- summaries ]
-msDeps :: ModSummary -> [(FilePath, -- Importing module
- Module, -- Imported module
- IsBootInterface)] -- {-# SOURCE #-} import or not
+msDeps :: ModSummary -> [(Located Module, IsBootInterface)]
-- (msDeps s) returns the dependencies of the ModSummary s.
-- A wrinkle is that for a {-# SOURCE #-} import we return
-- *both* the hs-boot file
-- modules always contains B.hs if it contains B.hs-boot.
-- Remember, this pass isn't doing the topological sort. It's
-- just gathering the list of all relevant ModSummaries
-msDeps s = concat [ [(f, m, True), (f,m,False)] | m <- ms_srcimps s]
- ++ [(f,m,False) | m <- ms_imps s]
- where
- f = msHsFilePath s -- Keep the importing module for error reporting
-
+msDeps s =
+ concat [ [(m,True), (m,False)] | m <- ms_srcimps s ]
+ ++ [ (m,False) | m <- ms_imps s ]
-----------------------------------------------------------------------------
-- Summarising modules
-- a summary. The finder is used to locate the file in which the module
-- resides.
-summariseFile :: HscEnv -> FilePath -> IO ModSummary
--- Used for Haskell source only, I think
--- We know the file name, and we know it exists,
--- but we don't necessarily know the module name (might differ)
-summariseFile hsc_env file
- = do let dflags = hsc_dflags hsc_env
+summariseFile
+ :: HscEnv
+ -> [ModSummary] -- old summaries
+ -> FilePath -- source file name
+ -> Maybe Phase -- start phase
+ -> Maybe (StringBuffer,ClockTime)
+ -> IO ModSummary
+
+summariseFile hsc_env old_summaries file mb_phase 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.
+ | Just old_summary <- findSummaryBySourceFile old_summaries file
+ = do
+ let location = ms_location old_summary
- (dflags', hspp_fn) <- preprocess dflags file
- -- The dflags' contains the OPTIONS pragmas
+ -- return the cached summary if the source didn't change
+ src_timestamp <- case maybe_buf of
+ Just (_,t) -> return t
+ Nothing -> 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
+ -- behaviour.
+
+ if ms_hs_date old_summary == src_timestamp
+ then do -- update the object-file timestamp
+ obj_timestamp <- getObjTimestamp location False
+ return old_summary{ ms_obj_date = obj_timestamp }
+ else
+ new_summary
- -- Read the file into a buffer. We're going to cache
- -- this buffer in the ModLocation (ml_hspp_buf) so that it
- -- doesn't have to be slurped again when hscMain parses the
- -- file later.
- buf <- hGetStringBuffer hspp_fn
- (srcimps,the_imps,mod) <- getImports dflags' buf hspp_fn
+ | otherwise
+ = new_summary
+ where
+ new_summary = do
+ let dflags = hsc_dflags hsc_env
+
+ (dflags', hspp_fn, buf)
+ <- preprocessFile dflags file mb_phase maybe_buf
+
+ (srcimps,the_imps, L _ mod) <- getImports dflags' buf hspp_fn
-- Make a ModLocation for this file
location <- mkHomeModLocation dflags mod file
-- to findModule will find it, even if it's not on any search path
addHomeModuleToFinder hsc_env mod location
- src_timestamp <- getModificationTime file
+ src_timestamp <- case maybe_buf of
+ Just (_,t) -> return t
+ Nothing -> getModificationTime file
+ -- getMofificationTime may fail
+
+ obj_timestamp <- modificationTimeIfExists (ml_obj_file location)
+
return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
ms_location = location,
ms_hspp_file = Just hspp_fn,
ms_hspp_buf = Just buf,
ms_srcimps = srcimps, ms_imps = the_imps,
- ms_hs_date = src_timestamp })
+ ms_hs_date = src_timestamp,
+ ms_obj_date = obj_timestamp })
+
+findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
+findSummaryBySourceFile summaries file
+ = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
+ fromJust (ml_hs_file (ms_location ms)) == file ] of
+ [] -> Nothing
+ (x:xs) -> Just x
-- Summarise a module, and pick up source and timestamp.
-summarise :: HscEnv
+summariseModule
+ :: HscEnv
-> NodeMap ModSummary -- Map of old summaries
- -> Maybe FilePath -- Importing module (for error messages)
-> IsBootInterface -- True <=> a {-# SOURCE #-} import
- -> Module -- Imported module to be summarised
+ -> Located Module -- Imported module to be summarised
+ -> Maybe (StringBuffer, ClockTime)
-> [Module] -- Modules to exclude
-> IO (Maybe ModSummary) -- Its new summary
-summarise hsc_env old_summary_map cur_mod is_boot wanted_mod excl_mods
+summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf excl_mods
| wanted_mod `elem` excl_mods
= return Nothing
| Just old_summary <- lookupFM old_summary_map (wanted_mod, hsc_src)
- = do { -- Find its new timestamp; all the
+ = do -- Find its new timestamp; all the
-- ModSummaries in the old map have valid ml_hs_files
- let location = ms_location old_summary
- src_fn = fromJust (ml_hs_file location)
-
- ; src_timestamp <- getModificationTime src_fn
+ let location = ms_location old_summary
+ src_fn = expectJust "summariseModule" (ml_hs_file location)
+
+ -- check the modification time on the source file, and
+ -- return the cached summary if it hasn't changed. If the
+ -- file has disappeared, we need to call the Finder again.
+ case maybe_buf of
+ Just (_,t) -> check_timestamp old_summary location src_fn t
+ Nothing -> do
+ m <- 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 = find_it
+ where
+ dflags = hsc_dflags hsc_env
- -- return the cached summary if the source didn't change
- ; if ms_hs_date old_summary == src_timestamp
- then return (Just old_summary)
- else new_summary location
- }
+ hsc_src = if is_boot then HsBootFile else HsSrcFile
- | otherwise
- = do { found <- findModule hsc_env wanted_mod True {-explicit-}
- ; case found of
+ 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
+ return (Just old_summary{ ms_obj_date = obj_timestamp })
+ | otherwise =
+ -- source changed: find and re-summarise. We call the finder
+ -- again, because the user may have moved the source file.
+ new_summary location src_fn src_timestamp
+
+ find_it = do
+ -- Don't use the Finder's cache this time. If the module was
+ -- 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 <- findModule hsc_env wanted_mod True {-explicit-}
+ case found of
Found location pkg
- | not (isHomePackage pkg) -> return Nothing
+ | not (isHomePackage pkg) -> return Nothing
-- Drop external-pkg
- | isJust (ml_hs_file location) -> new_summary location
+ | isJust (ml_hs_file location) -> just_found location
-- Home package
- err -> noModError dflags cur_mod wanted_mod err
+ err -> noModError dflags loc wanted_mod err
-- Not found
- }
- where
- dflags = hsc_dflags hsc_env
-
- hsc_src = if is_boot then HsBootFile else HsSrcFile
- new_summary location
- = do { -- Adjust location to point to the hs-boot source file,
+ just_found location = do
+ -- Adjust location to point to the hs-boot source file,
-- hi file, object file, when is_boot says so
- let location' | is_boot = addBootSuffixLocn location
- | otherwise = location
- src_fn = fromJust (ml_hs_file location')
+ let location' | is_boot = addBootSuffixLocn location
+ | otherwise = location
+ src_fn = expectJust "summarise2" (ml_hs_file location')
-- Check that it exists
- -- It might have been deleted since the Finder last found it
- ; exists <- doesFileExist src_fn
- ; if exists then return () else noHsFileErr cur_mod src_fn
+ -- It might have been deleted since the Finder last found it
+ maybe_t <- modificationTimeIfExists src_fn
+ case maybe_t of
+ Nothing -> noHsFileErr loc src_fn
+ Just t -> new_summary location' src_fn t
+
+ new_summary location src_fn src_timestamp
+ = do
-- Preprocess the source file and get its imports
-- The dflags' contains the OPTIONS pragmas
- ; (dflags', hspp_fn) <- preprocess dflags src_fn
- ; buf <- hGetStringBuffer hspp_fn
- ; (srcimps, the_imps, mod_name) <- getImports dflags' buf hspp_fn
-
- ; when (mod_name /= wanted_mod) $
- throwDyn (ProgramError
- (showSDoc (text src_fn
- <> text ": file name does not match module name"
- <+> quotes (ppr mod_name))))
-
- -- Find its timestamp, and return the summary
- ; src_timestamp <- getModificationTime src_fn
- ; return (Just ( ModSummary { ms_mod = wanted_mod,
- ms_hsc_src = hsc_src,
- ms_location = location',
- ms_hspp_file = Just hspp_fn,
- ms_hspp_buf = Just buf,
- ms_srcimps = srcimps,
- ms_imps = the_imps,
- ms_hs_date = src_timestamp }))
- }
+ (dflags', hspp_fn, buf) <- preprocessFile dflags src_fn Nothing maybe_buf
+ (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn
+
+ when (mod_name /= wanted_mod) $
+ throwDyn $ mkPlainErrMsg mod_loc $
+ text "file name does not match module name"
+ <+> quotes (ppr mod_name)
+
+ -- Find the object timestamp, and return the summary
+ obj_timestamp <- getObjTimestamp location is_boot
+
+ return (Just ( ModSummary { ms_mod = wanted_mod,
+ ms_hsc_src = hsc_src,
+ ms_location = location,
+ ms_hspp_file = Just hspp_fn,
+ ms_hspp_buf = Just buf,
+ ms_srcimps = srcimps,
+ ms_imps = the_imps,
+ ms_hs_date = src_timestamp,
+ ms_obj_date = obj_timestamp }))
+
+
+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
+ = do
+ (dflags', hspp_fn) <- preprocess dflags (src_fn, mb_phase)
+ buf <- hGetStringBuffer hspp_fn
+ return (dflags', hspp_fn, buf)
+
+preprocessFile dflags src_fn mb_phase (Just (buf, time))
+ = do
+ -- case we bypass the preprocessing stage?
+ let
+ local_opts = getOptionsFromStringBuffer buf src_fn
+ --
+ (dflags', errs) <- parseDynamicFlags dflags (map snd local_opts)
+
+ let
+ needs_preprocessing
+ | Just (Unlit _) <- mb_phase = True
+ | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True
+ -- note: local_opts is only required if there's no Unlit phase
+ | dopt Opt_Cpp dflags' = True
+ | dopt Opt_Pp dflags' = True
+ | otherwise = False
+
+ when needs_preprocessing $
+ ghcError (ProgramError "buffer needs preprocesing; interactive check disabled")
+
+ return (dflags', src_fn, buf)
-----------------------------------------------------------------------------
-- Error messages
-----------------------------------------------------------------------------
-noModError :: DynFlags -> Maybe FilePath -> Module -> FindResult -> IO ab
+noModError :: DynFlags -> SrcSpan -> Module -> FindResult -> IO ab
-- ToDo: we don't have a proper line number for this error
-noModError dflags cur_mod wanted_mod err
- = throwDyn $ ProgramError $ showSDoc $
- vcat [cantFindError dflags wanted_mod err,
- nest 2 (parens (pp_where cur_mod))]
+noModError dflags loc wanted_mod err
+ = throwDyn $ mkPlainErrMsg loc $ cantFindError dflags wanted_mod err
-noHsFileErr cur_mod path
- = throwDyn $ CmdLineError $ showSDoc $
- vcat [text "Can't find" <+> text path,
- nest 2 (parens (pp_where cur_mod))]
+noHsFileErr loc path
+ = throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path
-pp_where Nothing = text "one of the roots of the dependency analysis"
-pp_where (Just p) = text "imported from" <+> text p
-
packageModErr mod
- = throwDyn (CmdLineError (showSDoc (text "module" <+>
- quotes (ppr mod) <+>
- text "is a package module")))
+ = throwDyn $ mkPlainErrMsg noSrcSpan $
+ text "module" <+> quotes (ppr mod) <+> text "is a package module"
-multiRootsErr mod files
- = throwDyn (ProgramError (showSDoc (
+multiRootsErr :: [ModSummary] -> IO ()
+multiRootsErr summs@(summ1:_)
+ = throwDyn $ mkPlainErrMsg noSrcSpan $
text "module" <+> quotes (ppr mod) <+>
text "is defined in multiple files:" <+>
- sep (map text files))))
+ sep (map text files)
+ where
+ mod = ms_mod summ1
+ files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
cyclicModuleErr :: [ModSummary] -> SDoc
cyclicModuleErr ms
-- -----------------------------------------------------------------------------
-- inspecting the session
--- | Get the module dependency graph. After a 'load', this will contain
--- only the modules that were successfully loaded.
+-- | Get the module dependency graph.
getModuleGraph :: Session -> IO ModuleGraph -- ToDo: DiGraph ModSummary
getModuleGraph s = withSession s (return . hsc_mod_graph)
+isLoaded :: Session -> Module -> IO Bool
+isLoaded s m = withSession s $ \hsc_env ->
+ return $! isJust (lookupModuleEnv (hsc_HPT hsc_env) m)
+
getBindings :: Session -> IO [TyThing]
getBindings s = withSession s (return . nameEnvElts . ic_type_env . hsc_IC)
getPrintUnqual :: Session -> IO PrintUnqualified
getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC)
-#if 0
-getModuleInfo :: Session -> Module -> IO ModuleInfo
-
-data ObjectCode
- = ByteCode
- | BinaryCode FilePath
-
+-- | Container for information about a 'Module'.
data ModuleInfo = ModuleInfo {
- lm_modulename :: Module,
- lm_summary :: ModSummary,
- lm_interface :: ModIface,
- lm_tc_code :: Maybe TypecheckedCode,
- lm_rn_code :: Maybe RenamedCode,
- lm_obj :: Maybe ObjectCode
+ minf_type_env :: TypeEnv,
+ minf_exports :: NameSet,
+ minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod
+ minf_instances :: [Instance]
+ -- ToDo: this should really contain the ModIface too
}
+ -- We don't want HomeModInfo here, because a ModuleInfo applies
+ -- to package modules too.
+
+-- | Request information about a loaded 'Module'
+getModuleInfo :: Session -> Module -> IO (Maybe ModuleInfo)
+getModuleInfo s mdl = withSession s $ \hsc_env -> do
+ let mg = hsc_mod_graph hsc_env
+ if mdl `elem` map ms_mod mg
+ then getHomeModuleInfo hsc_env mdl
+ else do
+ {- if isHomeModule (hsc_dflags hsc_env) mdl
+ then return Nothing
+ else -} 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
+ (_msgs, mb_names) <- getModuleExports hsc_env mdl
+ case mb_names of
+ Nothing -> return Nothing
+ Just names -> do
+ eps <- readIORef (hsc_EPS hsc_env)
+ let
+ pte = eps_PTE eps
+ n_list = nameSetToList names
+ tys = [ ty | name <- n_list,
+ Just ty <- [lookupTypeEnv pte name] ]
+ --
+ return (Just (ModuleInfo {
+ minf_type_env = mkTypeEnv tys,
+ minf_exports = names,
+ minf_rdr_env = Just $! nameSetToGlobalRdrEnv names mdl,
+ minf_instances = error "getModuleInfo: instances for package module unimplemented"
+ }))
+#else
+ -- bogusly different for non-GHCI (ToDo)
+ return Nothing
+#endif
-type TypecheckedCode = HsTypecheckedGroup
-type RenamedCode = [HsGroup Name]
+getHomeModuleInfo hsc_env mdl =
+ case lookupModuleEnv (hsc_HPT hsc_env) mdl of
+ Nothing -> return Nothing
+ Just hmi -> do
+ let details = hm_details hmi
+ return (Just (ModuleInfo {
+ minf_type_env = md_types details,
+ minf_exports = md_exports details,
+ minf_rdr_env = mi_globals $! hm_iface hmi,
+ minf_instances = md_insts details
+ }))
+
+-- | The list of top-level entities defined in a module
+modInfoTyThings :: ModuleInfo -> [TyThing]
+modInfoTyThings minf = typeEnvElts (minf_type_env minf)
+
+modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
+modInfoTopLevelScope minf
+ = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)
+
+modInfoExports :: ModuleInfo -> [Name]
+modInfoExports minf = nameSetToList $! minf_exports minf
+
+-- | Returns the instances defined by the specified module.
+-- Warning: currently unimplemented for package modules.
+modInfoInstances :: ModuleInfo -> [Instance]
+modInfoInstances = minf_instances
+
+modInfoIsExportedName :: ModuleInfo -> Name -> Bool
+modInfoIsExportedName minf name = elemNameSet name (minf_exports minf)
+
+modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified
+modInfoPrintUnqualified minf = fmap unQualInScope (minf_rdr_env minf)
+
+modInfoLookupName :: Session -> ModuleInfo -> Name -> IO (Maybe TyThing)
+modInfoLookupName s minf name = withSession s $ \hsc_env -> do
+ case lookupTypeEnv (minf_type_env minf) name of
+ Just tyThing -> return (Just tyThing)
+ Nothing -> do
+ eps <- readIORef (hsc_EPS hsc_env)
+ return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name
+
+isDictonaryId :: Id -> Bool
+isDictonaryId id
+ = 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_HPT hsc_env) (eps_PTE eps) name
--- ToDo: typechecks abstract syntax or renamed abstract syntax. Issues:
--- - typechecked syntax includes extra dictionary translation and
--- AbsBinds which need to be translated back into something closer to
--- the original source.
--- - renamed syntax currently doesn't exist in a single blob, since
--- renaming and typechecking are interleaved at splice points. We'd
--- need a restriction that there are no splices in the source module.
+-- -----------------------------------------------------------------------------
+-- Misc exported utils
--- ToDo:
--- - Data and Typeable instances for HsSyn.
+dataConType :: DataCon -> Type
+dataConType dc = idType (dataConWrapId dc)
--- ToDo:
--- - things that aren't in the output of the renamer:
--- - the export list
--- - the imports
+-- | print a 'NamedThing', adding parentheses if the name is an operator.
+pprParenSymName :: NamedThing a => a -> SDoc
+pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
+
+-- ----------------------------------------------------------------------------
+
+#if 0
-- ToDo:
--- - things that aren't in the output of the typechecker right now:
--- - the export list
--- - the imports
--- - type signatures
--- - type/data/newtype declarations
--- - class declarations
--- - instances
--- - extra things in the typechecker's output:
--- - default methods are turned into top-level decls.
--- - dictionary bindings
+-- - Data and Typeable instances for HsSyn.
-- ToDo: check for small transformations that happen to the syntax in
-- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral)
-- :browse will use either lm_toplev or inspect lm_interface, depending
-- on whether the module is interpreted or not.
--- various abstract syntax types (perhaps IfaceBlah)
-data Type = ...
-data Kind = ...
-
-- This is for reconstructing refactored source code
-- Calls the lexer repeatedly.
-- ToDo: add comment tokens to token stream
hsc_env <- readIORef ref
let old_ic = hsc_IC hsc_env
hpt = hsc_HPT hsc_env
- dflags = hsc_dflags hsc_env
mapM_ (checkModuleExists hsc_env hpt) exports
export_env <- mkExportEnv hsc_env exports
let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplevs,
ic_exports = exports,
- ic_rn_gbl_env = all_env } }
+ ic_rn_gbl_env = all_env }}
+
+
+-- Make a GlobalRdrEnv based on the exports of the modules only.
+mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
+mkExportEnv hsc_env mods = do
+ stuff <- mapM (getModuleExports hsc_env) mods
+ let
+ (_msgs, mb_name_sets) = unzip stuff
+ gres = [ nameSetToGlobalRdrEnv name_set mod
+ | (Just name_set, mod) <- zip mb_name_sets mods ]
+ --
+ return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
+
+nameSetToGlobalRdrEnv :: NameSet -> Module -> GlobalRdrEnv
+nameSetToGlobalRdrEnv names mod =
+ mkGlobalRdrEnv [ GRE { gre_name = name, gre_prov = vanillaProv mod }
+ | name <- nameSetToList names ]
+
+vanillaProv :: Module -> Provenance
+-- We're building a GlobalRdrEnv as if the user imported
+-- all the specified modules into the global interactive module
+vanillaProv mod = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
+ where
+ decl = ImpDeclSpec { is_mod = mod, is_as = mod,
+ is_qual = False,
+ is_dloc = srcLocSpan interactiveSrcLoc }
checkModuleExists :: HscEnv -> HomePackageTable -> Module -> IO ()
checkModuleExists hsc_env hpt mod =
_not_a_home_module -> return False
-- | Looks up an identifier in the current interactive context (for :info)
-getInfo :: Session -> String -> IO [GetInfoResult]
-getInfo s id = withSession s $ \hsc_env -> hscGetInfo hsc_env id
+getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
+getInfo s name = withSession s $ \hsc_env -> tcRnGetInfo hsc_env name
+
+-- | Returns all names in scope in the current interactive context
+getNamesInScope :: Session -> IO [Name]
+getNamesInScope s = withSession s $ \hsc_env -> do
+ return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
+
+getRdrNamesInScope :: Session -> IO [RdrName]
+getRdrNamesInScope s = withSession s $ \hsc_env -> do
+ let env = ic_rn_gbl_env (hsc_IC hsc_env)
+ return (concat (map greToRdrNames (globalRdrEnvElts env)))
+
+-- ToDo: move to RdrName
+greToRdrNames :: GlobalRdrElt -> [RdrName]
+greToRdrNames GRE{ gre_name = name, gre_prov = prov }
+ = case prov of
+ LocalDef -> [unqual]
+ Imported specs -> concat (map do_spec (map is_decl specs))
+ where
+ occ = nameOccName name
+ unqual = Unqual occ
+ do_spec decl_spec
+ | is_qual decl_spec = [qual]
+ | otherwise = [unqual,qual]
+ where qual = Qual (is_as decl_spec) occ
+
+-- | Parses a string as an identifier, and returns the list of 'Name's that
+-- the identifier can refer to in the current interactive context.
+parseName :: Session -> String -> IO [Name]
+parseName s str = withSession s $ \hsc_env -> do
+ maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
+ case maybe_rdr_name of
+ Nothing -> return []
+ Just (L _ rdr_name) -> do
+ mb_names <- tcRnLookupRdrName hsc_env rdr_name
+ case mb_names of
+ Nothing -> return []
+ Just ns -> return ns
+ -- ToDo: should return error messages
+
+-- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any
+-- entity known to GHC, including 'Name's defined using 'runStmt'.
+lookupName :: Session -> Name -> IO (Maybe TyThing)
+lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name
-- -----------------------------------------------------------------------------
-- Getting the type of an expression
Just ty -> return (Just tidy_ty)
where
tidy_ty = tidyType emptyTidyEnv ty
- dflags = hsc_dflags hsc_env
-- -----------------------------------------------------------------------------
-- Getting the kind of a type
Just kind -> return (Just kind)
-----------------------------------------------------------------------------
--- lookupName: returns the TyThing for a Name in the interactive context.
--- ToDo: should look it up in the full environment
-
-lookupName :: Session -> Name -> IO (Maybe TyThing)
-lookupName s name = withSession s $ \hsc_env -> do
- return $! lookupNameEnv (ic_type_env (hsc_IC hsc_env)) name
-
------------------------------------------------------------------------------
-- cmCompileExpr: compile an expression and deliver an HValue
compileExpr :: Session -> String -> IO (Maybe HValue)
writeIORef ref new_hsc_env
return (RunOk names)
-
--- We run the statement in a "sandbox" to protect the rest of the
--- system from anything the expression might do. For now, this
--- consists of just wrapping it in an exception handler, but see below
--- for another version.
-
+-- When running a computation, we redirect ^C exceptions to the running
+-- thread. ToDo: we might want a way to continue even if the target
+-- thread doesn't die when it receives the exception... "this thread
+-- is not responding".
sandboxIO :: IO a -> IO (Either Exception a)
-sandboxIO thing = Exception.try thing
+sandboxIO thing = do
+ m <- newEmptyMVar
+ ts <- takeMVar interruptTargetThread
+ child <- forkIO (do res <- Exception.try thing; putMVar m res)
+ putMVar interruptTargetThread (child:ts)
+ takeMVar m `finally` modifyMVar_ interruptTargetThread (return.tail)
{-
-- This version of sandboxIO runs the expression in a completely new
-- more informative than the C type!
-}
--- ---------------------------------------------------------------------------
--- cmBrowseModule: get all the TyThings defined in a module
-
-browseModule :: Session -> Module -> Bool -> IO [IfaceDecl]
-browseModule s modl exports_only = withSession s $ \hsc_env -> do
- mb_decls <- getModuleContents hsc_env modl exports_only
- case mb_decls of
- Nothing -> return [] -- An error of some kind
- Just ds -> return ds
-
-
-----------------------------------------------------------------------------
-- show a module and it's source/object filenames
Nothing -> panic "missing linkable"
Just mod_info -> return (showModMsg obj_linkable mod_summary)
where
- obj_linkable = isObjectLinkable (hm_linkable mod_info)
+ obj_linkable = isObjectLinkable (fromJust (hm_linkable mod_info))
#endif /* GHCI */
projects / ghc-hetmet.git / blobdiff