depanal,
load, LoadHowMuch(..), SuccessFlag(..), -- also does depanal
workingDirectoryChanged,
- checkModule, CheckedModule(..),
+ checkModule, checkAndLoadModule, CheckedModule(..),
TypecheckedSource, ParsedSource, RenamedSource,
- compileToCore,
+ compileToCore, compileToCoreModule, compileToCoreSimplified,
+ compileCoreToObj,
-- * Parsing Haddock comments
parseHaddockComment,
getModuleInfo,
modInfoTyThings,
modInfoTopLevelScope,
- modInfoPrintUnqualified,
- modInfoExports,
+ modInfoExports,
modInfoInstances,
modInfoIsExportedName,
modInfoLookupName,
lookupGlobalName,
+ mkPrintUnqualifiedForModule,
-- * Printing
PrintUnqualified, alwaysQualify,
setContext, getContext,
getNamesInScope,
getRdrNamesInScope,
+ getGRE,
moduleIsInterpreted,
getInfo,
exprType,
resume,
Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
resumeHistory, resumeHistoryIx),
- History(historyBreakInfo), getHistorySpan,
+ History(historyBreakInfo, historyEnclosingDecl),
+ GHC.getHistorySpan, getHistoryModule,
getResumeContext,
abandon, abandonAll,
InteractiveEval.back,
InteractiveEval.forward,
showModule,
isModuleInterpreted,
- compileExpr, HValue, dynCompileExpr,
+ InteractiveEval.compileExpr, HValue, dynCompileExpr,
lookupName,
- obtainTerm, obtainTerm1,
+ GHC.obtainTerm, GHC.obtainTerm1, GHC.obtainTermB, reconstructType,
modInfoModBreaks,
ModBreaks(..), BreakIndex,
BreakInfo(breakInfo_number, breakInfo_module),
instanceDFunId, pprInstance, pprInstanceHdr,
-- ** Types and Kinds
- Type, dropForAlls, splitForAllTys, funResultTy,
- pprParendType, pprTypeApp,
+ Type, splitForAllTys, funResultTy,
+ pprParendType, pprTypeApp,
Kind,
PredType,
ThetaType, pprThetaArrow,
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 DataCon
import Name hiding ( varName )
import OccName ( parenSymOcc )
-import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr )
+import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr,
+ emptyInstEnv )
+import FamInstEnv ( emptyFamInstEnv )
import SrcLoc
-import Desugar
import CoreSyn
-import TcRnDriver ( tcRnModule )
+import TidyPgm
import DriverPipeline
import DriverPhases ( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase )
import HeaderInfo ( getImports, getOptions )
import Finder
-import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) )
+import HscMain
import HscTypes
import DynFlags
import StaticFlags
import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
cleanTempDirs )
import Module
-import UniqFM
+import LazyUniqFM
import UniqSet
import Unique
-import PackageConfig
import FiniteMap
import Panic
import Digraph
import Maybes ( expectJust, mapCatMaybes )
import HaddockParse
import HaddockLex ( tokenise )
+import FastString
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 Control.Monad
import System.Exit ( exitWith, ExitCode(..) )
-import System.Time ( ClockTime )
+import System.Time ( ClockTime, getClockTime )
import Control.Exception as Exception hiding (handle)
import Data.IORef
+import System.FilePath
import System.IO
import System.IO.Error ( try, isDoesNotExistError )
import Prelude hiding (init)
-- | Starts a new session. A session consists of a set of loaded
-- modules, a set of options (DynFlags), and an interactive context.
+-- ToDo: explain argument [[mb_top_dir]]
newSession :: Maybe FilePath -> IO Session
newSession mb_top_dir = do
-- catch ^C
let isMain = (== mainModIs dflags) . ms_mod
[ms] <- return (filter isMain mod_graph)
ml_hs_file (ms_location ms)
- guessedName = fmap basenameOf mainModuleSrcPath
+ guessedName = fmap dropExtension mainModuleSrcPath
in
case outputFile dflags of
Just _ -> env
else do
return (Target (TargetModule (mkModuleName file)) Nothing)
where
- hs_file = file `joinFileExt` "hs"
- lhs_file = file `joinFileExt` "lhs"
+ hs_file = file <.> "hs"
+ lhs_file = file <.> "lhs"
-- -----------------------------------------------------------------------------
-- Extending the program scope
-- Parsing Haddock comments
parseHaddockComment :: String -> Either String (HsDoc RdrName)
-parseHaddockComment string = parseHaddockParagraphs (tokenise string)
+parseHaddockComment string =
+ case parseHaddockParagraphs (tokenise string) of
+ MyLeft x -> Left x
+ MyRight x -> Right x
-- -----------------------------------------------------------------------------
-- Loading the program
-- 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
+ 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 :: Session -> LoadHowMuch -> [ModSummary] -> IO SuccessFlag
load2 s@(Session ref) how_much mod_graph = do
guessOutputFile s
hsc_env <- readIORef ref
-- (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 ()
-- mg2_with_srcimps drops the hi-boot nodes, returning a
-- 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
-- Finish up after a load.
-- If the link failed, unload everything and return.
-loadFinish all_ok Failed ref hsc_env
+loadFinish :: SuccessFlag -> SuccessFlag -> IORef HscEnv -> HscEnv -> IO SuccessFlag
+loadFinish _all_ok Failed ref hsc_env
= do unload hsc_env []
writeIORef ref $! discardProg hsc_env
return Failed
-- 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
-- -----------------------------------------------------------------------------
renamedSource :: Maybe RenamedSource,
typecheckedSource :: Maybe TypecheckedSource,
checkedModuleInfo :: Maybe ModuleInfo,
- coreBinds :: Maybe [CoreBind]
+ coreModule :: Maybe ModGuts
}
-- ToDo: improvements that could be made here:
-- if the module succeeded renaming but not typechecking,
-- 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
+checkModule (Session ref) mod compile_to_core
+ = do
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
+ (ms:_) -> checkModule_ ref ms compile_to_core False
+
+-- | parses and typechecks a module, optionally generates Core, and also
+-- loads the module into the 'Session' so that modules which depend on
+-- this one may subsequently be typechecked using 'checkModule' or
+-- 'checkAndLoadModule'. If you need to check more than one module,
+-- you probably want to use 'checkAndLoadModule'. Constructing the
+-- interface takes a little work, so it might be slightly slower than
+-- 'checkModule'.
+checkAndLoadModule :: Session -> ModSummary -> Bool -> IO (Maybe CheckedModule)
+checkAndLoadModule (Session ref) ms compile_to_core
+ = checkModule_ ref ms compile_to_core True
+
+checkModule_ :: IORef HscEnv -> ModSummary -> Bool -> Bool
+ -> IO (Maybe CheckedModule)
+checkModule_ ref ms compile_to_core load
+ = do
+ let mod = ms_mod_name ms
+ hsc_env0 <- readIORef ref
+ let hsc_env = hsc_env0{hsc_dflags=ms_hspp_opts ms}
+ mb_parsed <- parseFile hsc_env ms
+ case mb_parsed 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
+ Just rdr_module -> do
+ mb_typechecked <- typecheckRenameModule hsc_env ms rdr_module
+ case mb_typechecked of
+ Nothing -> return (Just CheckedModule {
+ parsedSource = rdr_module,
+ renamedSource = Nothing,
+ typecheckedSource = Nothing,
+ checkedModuleInfo = Nothing,
+ coreModule = Nothing })
+ Just (tcg, rn_info) -> do
+ details <- makeSimpleDetails hsc_env tcg
+
+ let tc_binds = tcg_binds tcg
+ let rdr_env = tcg_rdr_env tcg
let minf = ModuleInfo {
minf_type_env = md_types details,
minf_exports = availsToNameSet $
,minf_modBreaks = emptyModBreaks
#endif
}
+
+ mb_guts <- if compile_to_core
+ then deSugarModule hsc_env ms tcg
+ else return Nothing
+
+ -- If we are loading this module so that we can typecheck
+ -- dependent modules, generate an interface and stuff it
+ -- all in the HomePackageTable.
+ when load $ do
+ (iface,_) <- makeSimpleIface hsc_env Nothing tcg details
+ let mod_info = HomeModInfo {
+ hm_iface = iface,
+ hm_details = details,
+ hm_linkable = Nothing }
+ let hpt_new = addToUFM (hsc_HPT hsc_env) mod mod_info
+ writeIORef ref hsc_env0{ hsc_HPT = hpt_new }
+
return (Just (CheckedModule {
- parsedSource = parsed,
- renamedSource = renamed,
+ parsedSource = rdr_module,
+ renamedSource = rn_info,
typecheckedSource = Just tc_binds,
checkedModuleInfo = Just minf,
- coreBinds = maybeCoreBinds}))
+ coreModule = mb_guts }))
-- | 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.
+-- desugar the module, then returns the resulting Core module (consisting of
+-- the module name, type declarations, and function declarations) if
+-- successful.
+compileToCoreModule :: Session -> FilePath -> IO (Maybe CoreModule)
+compileToCoreModule = compileCore False
+
+-- | Like compileToCoreModule, but invokes the simplifier, so
+-- as to return simplified and tidied Core.
+compileToCoreSimplified :: Session -> FilePath -> IO (Maybe 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 :: Session -> FilePath -> IO (Maybe [CoreBind])
-compileToCore session@(Session ref) fn = do
- hsc_env <- readIORef ref
+compileToCore session fn = do
+ maybeCoreModule <- compileToCoreModule session fn
+ return $ fmap cm_binds maybeCoreModule
+
+-- | 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.
+-- Returns True iff compilation succeeded.
+-- This has only so far been tested with a single self-contained module.
+compileCoreToObj :: Bool -> Session -> CoreModule -> IO Bool
+compileCoreToObj simplify session cm@(CoreModule{ cm_module = mName }) = do
+ hscEnv <- sessionHscEnv session
+ dflags <- getSessionDynFlags session
+ currentTime <- getClockTime
+ cwd <- getCurrentDirectory
+ modLocation <- 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
+ }
+
+ mbHscResult <- evalComp
+ ((if simplify then hscSimplify else return) (mkModGuts cm)
+ >>= hscNormalIface >>= hscWriteIface >>= hscOneShot)
+ (CompState{ compHscEnv=hscEnv,
+ compModSummary=modSummary,
+ compOldIface=Nothing})
+ return $ isJust mbHscResult
+
+-- 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_deprecs = NoDeprecs,
+ mg_hpc_info = emptyHpcInfo False,
+ mg_modBreaks = emptyModBreaks,
+ mg_vect_info = noVectInfo,
+ mg_inst_env = emptyInstEnv,
+ mg_fam_inst_env = emptyFamInstEnv
+}
+
+compileCore :: Bool -> Session -> FilePath -> IO (Maybe CoreModule)
+compileCore simplify session fn = do
-- First, set the target to the desired filename
target <- guessTarget fn Nothing
addTarget session target
maybeCheckedModule <- checkModule session mod True
case maybeCheckedModule of
Nothing -> return Nothing
- Just checkedMod -> return $ coreBinds checkedMod
- -- ---------------------------------------------------------------------------
+ Just checkedMod -> (liftM $ fmap gutsToCoreModule) $
+ case (coreModule checkedMod) of
+ Just mg | simplify -> (sessionHscEnv session)
+ -- If simplify is true: simplify (hscSimplify),
+ -- then tidy (tidyProgram).
+ >>= \ hscEnv -> evalComp (hscSimplify mg)
+ (CompState{ compHscEnv=hscEnv,
+ compModSummary=modSummary,
+ compOldIface=Nothing})
+ >>= (tidyProgram hscEnv)
+ >>= (return . Just . Left)
+ Just guts -> return $ Just $ Right guts
+ Nothing -> return Nothing
+ 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 ()
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
= 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
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 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 stable_mods cleanup
+ 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, [])
+ 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)
cleanup -- Remove unwanted tmp files between compilations
case mb_mod_info of
- Nothing -> return (Failed, hsc_env, [])
+ Nothing -> return (Failed, hsc_env, done)
Just mod_info -> do
- { let this_mod = ms_mod_name mod
+ 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
+
+ done' = mod:done
+
+ -- fixup our HomePackageTable after we've finished compiling
+ -- a mutually-recursive loop. See reTypecheckLoop, below.
+ hsc_env2 <- reTypecheckLoop hsc_env1 mod done'
- ; (restOK, hsc_env2, modOKs)
- <- upsweep' hsc_env1 old_hpt1 stable_mods cleanup
- mods (mod_index+1) nmods
- ; return (restOK, hsc_env2, mod:modOKs)
- }
+ upsweep' hsc_env2 old_hpt1 done' mods (mod_index+1) nmods
-- Compile a single module. Always produce a Linkable for it if
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 = compile hsc_env summary' mod_index nmods mb_old_iface
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
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
-
- 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
retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
, 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,_,_) <- map vertex_fn nodes_we_want ]
+ where
+ -- all the nodes reachable by traversing the edges backwards
+ -- from the root node:
+ nodes_we_want = reachable (transposeG graph) root
+
+ -- the rest just sets up the graph:
+ (nodes, lookup_key) = moduleGraphNodes False summaries
+ (graph, vertex_fn, key_fn) = graphFromEdges' nodes
+ root
+ | Just key <- lookup_key HsBootFile mod, Just v <- key_fn key = v
+ | otherwise = panic "reachableBackwards"
+
+-- ---------------------------------------------------------------------------
-- Topological sort of the module graph
topSortModuleGraph
printBagOfWarnings dflags (listToBag (concat (map (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,
+ [ warn i | m <- ms, i <- ms_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))
-----------------------------------------------------------------------------
Nothing -> packageModErr modl
Just s -> return s
- rootLoc = mkGeneralSrcSpan FSLIT("<command line>")
+ 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
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
= 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
= 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)
+ 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
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)
+preprocessFile :: HscEnv -> FilePath -> Maybe Phase -> Maybe (StringBuffer,ClockTime)
-> IO (DynFlags, FilePath, StringBuffer)
-preprocessFile dflags src_fn mb_phase Nothing
+preprocessFile hsc_env src_fn mb_phase Nothing
= do
- (dflags', hspp_fn) <- preprocess dflags (src_fn, mb_phase)
+ (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)
buf <- 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
--
- (dflags', errs) <- parseDynamicFlags dflags (map unLoc local_opts)
+ (dflags', _errs) <- parseDynamicFlags dflags (map unLoc local_opts)
+ -- XXX: shouldn't we be reporting the errors?
let
needs_preprocessing
noModError dflags loc wanted_mod err
= throwDyn $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
+noHsFileErr :: SrcSpan -> String -> a
noHsFileErr loc path
= throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path
+packageModErr :: ModuleName -> a
packageModErr mod
= throwDyn $ mkPlainErrMsg noSrcSpan $
text "module" <+> quotes (ppr mod) <+> text "is a package module"
multiRootsErr :: [ModSummary] -> IO ()
+multiRootsErr [] = panic "multiRootsErr"
multiRootsErr summs@(summ1:_)
= throwDyn $ mkPlainErrMsg noSrcSpan $
text "module" <+> quotes (ppr mod) <+>
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:") <+>
+ nest 2 $ ptext (sLit "imports:") <+>
(pp_imps HsBootFile (ms_srcimps ms)
$$ pp_imps HsSrcFile (ms_imps ms))]
show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)
return filtered
getPrintUnqual :: Session -> IO PrintUnqualified
-getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC)
+getPrintUnqual s = withSession s $ \hsc_env ->
+ return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env))
-- | Container for information about a 'Module'.
data ModuleInfo = ModuleInfo {
-- 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
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
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
}))
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 :: Session -> ModuleInfo -> IO (Maybe PrintUnqualified)
+mkPrintUnqualifiedForModule s minf = withSession s $ \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
(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
return $! lookupType (hsc_dflags hsc_env)
(hsc_HPT hsc_env) (eps_PTE eps) name
+#ifdef GHCI
+-- | get the GlobalRdrEnv for a session
+getGRE :: Session -> IO GlobalRdrEnv
+getGRE s = withSession s $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env)
+#endif
+
-- -----------------------------------------------------------------------------
-- Misc exported utils
-- 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
text "is not loaded"))
err -> let msg = cannotFindModule dflags mod_name err in
throwDyn (CmdLineError (showSDoc msg))
+
+#ifdef GHCI
+getHistorySpan :: Session -> History -> IO SrcSpan
+getHistorySpan sess h = withSession sess $ \hsc_env ->
+ return$ InteractiveEval.getHistorySpan hsc_env h
+
+obtainTerm :: Session -> Bool -> Id -> IO Term
+obtainTerm sess force id = withSession sess $ \hsc_env ->
+ InteractiveEval.obtainTerm hsc_env force id
+
+obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term
+obtainTerm1 sess force mb_ty a = withSession sess $ \hsc_env ->
+ InteractiveEval.obtainTerm1 hsc_env force mb_ty a
+
+obtainTermB :: Session -> Int -> Bool -> Id -> IO Term
+obtainTermB sess bound force id = withSession sess $ \hsc_env ->
+ InteractiveEval.obtainTermB hsc_env bound force id
+
+#endif
projects / ghc-hetmet.git / blobdiff