X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=87d07dedd036a3cc30ee5c07b9fcf2fd86478dc4;hp=d54794b37e35a8c83be7b4c7546090b213cd0ca7;hb=cae75f82226638691cfa1e85fc168f4b65ddce4d;hpb=81f944da0ed9da6116800aeb575d6ea2a1937ac4 diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index d54794b..87d07de 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -39,9 +39,10 @@ module GHC ( 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, @@ -57,12 +58,12 @@ module GHC ( getModuleInfo, modInfoTyThings, modInfoTopLevelScope, - modInfoPrintUnqualified, - modInfoExports, + modInfoExports, modInfoInstances, modInfoIsExportedName, modInfoLookupName, lookupGlobalName, + mkPrintUnqualifiedForModule, -- * Printing PrintUnqualified, alwaysQualify, @@ -74,6 +75,7 @@ module GHC ( setContext, getContext, getNamesInScope, getRdrNamesInScope, + getGRE, moduleIsInterpreted, getInfo, exprType, @@ -92,7 +94,7 @@ module GHC ( InteractiveEval.forward, showModule, isModuleInterpreted, - compileExpr, HValue, dynCompileExpr, + InteractiveEval.compileExpr, HValue, dynCompileExpr, lookupName, GHC.obtainTerm, GHC.obtainTerm1, GHC.obtainTermB, reconstructType, modInfoModBreaks, @@ -154,8 +156,8 @@ module GHC ( instanceDFunId, pprInstance, pprInstanceHdr, -- ** Types and Kinds - Type, dropForAlls, splitForAllTys, funResultTy, - pprParendType, pprTypeApp, + Type, splitForAllTys, funResultTy, + pprParendType, pprTypeApp, Kind, PredType, ThetaType, pprThetaArrow, @@ -206,14 +208,18 @@ import Linker ( HValue ) import ByteCodeInstr import BreakArray import NameSet -import TcRnDriver import InteractiveEval +import TcRnDriver #endif +import TcIface +import TcRnTypes hiding (LIE) +import TcRnMonad ( initIfaceCheck ) import Packages import NameSet import RdrName -import HsSyn +import qualified HsSyn -- hack as we want to reexport the whole module +import HsSyn hiding ((<.>)) import Type hiding (typeKind) import TcType hiding (typeKind) import Id @@ -225,32 +231,31 @@ import FunDeps 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 CoreSyn +import TidyPgm import DriverPipeline import DriverPhases ( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase ) -import HeaderInfo ( getImports, getOptions ) +import HeaderInfo 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 Bag ( unitBag, listToBag ) -import ErrUtils ( Severity(..), showPass, fatalErrorMsg, debugTraceMsg, - mkPlainErrMsg, printBagOfErrors, printBagOfWarnings, - WarnMsg ) -import qualified ErrUtils +import ErrUtils import Util import StringBuffer ( StringBuffer, hGetStringBuffer ) import Outputable @@ -258,17 +263,20 @@ import BasicTypes 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) @@ -331,6 +339,7 @@ defaultCleanupHandler dflags inner = -- | 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 @@ -339,8 +348,8 @@ newSession mb_top_dir = do installSignalHandlers initStaticOpts - dflags0 <- initSysTools mb_top_dir defaultDynFlags - dflags <- initDynFlags dflags0 + dflags0 <- initDynFlags defaultDynFlags + dflags <- initSysTools mb_top_dir dflags0 env <- newHscEnv dflags ref <- newIORef env return (Session ref) @@ -381,16 +390,25 @@ guessOutputFile :: Session -> IO () guessOutputFile s = modifySession s $ \env -> let dflags = hsc_dflags env mod_graph = hsc_mod_graph env - mainModuleSrcPath, guessedName :: Maybe String + mainModuleSrcPath :: Maybe String mainModuleSrcPath = do let isMain = (== mainModIs dflags) . ms_mod [ms] <- return (filter isMain mod_graph) ml_hs_file (ms_location ms) - guessedName = fmap basenameOf mainModuleSrcPath + name = fmap dropExtension mainModuleSrcPath + +#if defined(mingw32_HOST_OS) + -- we must add the .exe extention unconditionally here, otherwise + -- when name has an extension of its own, the .exe extension will + -- not be added by DriverPipeline.exeFileName. See #2248 + name_exe = fmap (<.> "exe") name +#else + name_exe = name +#endif in case outputFile dflags of Just _ -> env - Nothing -> env { hsc_dflags = dflags { outputFile = guessedName } } + Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } } -- ----------------------------------------------------------------------------- -- Targets @@ -447,8 +465,8 @@ guessTarget file Nothing 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 @@ -479,7 +497,10 @@ setGlobalTypeScope session ids -- 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 @@ -530,7 +551,7 @@ data LoadHowMuch -- attempt to load up to this target. If no Module is supplied, -- then try to load all targets. load :: Session -> LoadHowMuch -> IO SuccessFlag -load s@(Session ref) how_much +load s how_much = do -- Dependency analysis first. Note that this fixes the module graph: -- even if we don't get a fully successful upsweep, the full module @@ -538,15 +559,8 @@ load s@(Session ref) how_much -- were successfully loaded by inspecting the Session's HPT. mb_graph <- depanal s [] False case mb_graph of - Just mod_graph -> catchingFailure $ load2 s how_much mod_graph + Just mod_graph -> 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 @@ -562,12 +576,25 @@ load2 s@(Session ref) how_much mod_graph = do -- (see msDeps) let all_home_mods = [ms_mod_name s | s <- mod_graph, not (isBootSummary s)] -#ifdef DEBUG bad_boot_mods = [s | s <- mod_graph, isBootSummary s, not (ms_mod_name s `elem` all_home_mods)] -#endif ASSERT( null bad_boot_mods ) return () + -- check that the module given in HowMuch actually exists, otherwise + -- topSortModuleGraph will bomb later. + let checkHowMuch (LoadUpTo m) = checkMod m + checkHowMuch (LoadDependenciesOf m) = checkMod m + checkHowMuch _ = id + + checkMod m and_then + | m `elem` all_home_mods = and_then + | otherwise = do + errorMsg dflags (text "no such module:" <+> + quotes (ppr m)) + return Failed + + checkHowMuch how_much $ do + -- mg2_with_srcimps drops the hi-boot nodes, returning a -- graph with cycles. Among other things, it is used for -- backing out partially complete cycles following a failed @@ -593,6 +620,12 @@ load2 s@(Session ref) how_much mod_graph = do evaluate pruned_hpt + -- before we unload anything, make sure we don't leave an old + -- interactive context around pointing to dead bindings. Also, + -- write the pruned HPT to allow the old HPT to be GC'd. + writeIORef ref $! hsc_env{ hsc_IC = emptyInteractiveContext, + hsc_HPT = pruned_hpt } + debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ text "Stable BCO:" <+> ppr stable_bco) @@ -636,7 +669,7 @@ load2 s@(Session ref) how_much mod_graph = do partial_mg | 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 @@ -772,7 +805,7 @@ data CheckedModule = 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, @@ -804,28 +837,49 @@ type TypecheckedSource = LHsBinds Id -- 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 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 $ @@ -836,19 +890,120 @@ checkModule (Session ref) mod compileToCore = do ,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 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_warns = NoWarnings, + 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 @@ -858,16 +1013,43 @@ compileToCore session fn = do case maybeModGraph of Nothing -> return Nothing Just modGraph -> do - let modSummary = expectJust "compileToCore" $ - find ((== fn) . msHsFilePath) modGraph - -- Now we have the module name; - -- parse, typecheck and desugar the module - let mod = ms_mod_name modSummary - maybeCheckedModule <- checkModule session mod True - case maybeCheckedModule of + case find ((== fn) . msHsFilePath) modGraph of + Just modSummary -> do + -- Now we have the module name; + -- parse, typecheck and desugar the module + let mod = ms_mod_name modSummary + maybeCheckedModule <- checkModule session mod True + case maybeCheckedModule of Nothing -> return Nothing - Just checkedMod -> return $ coreBinds checkedMod - -- --------------------------------------------------------------------------- + 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 () @@ -1067,20 +1249,21 @@ upsweep 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) @@ -1092,28 +1275,31 @@ upsweep hsc_env old_hpt stable_mods cleanup mods 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 @@ -1177,12 +1363,10 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods iface = hm_iface hm_info compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo) - compile_it = upsweep_compile hsc_env - 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 - summary' mod_index nmods Nothing + = compile hsc_env summary' mod_index nmods Nothing in case target of @@ -1244,27 +1428,6 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods compile_it Nothing --- Run hsc to compile a module -upsweep_compile :: HscEnv -> ModSummary -> Int -> Int - -> Maybe ModIface -> Maybe Linkable -> IO (Maybe HomeModInfo) -upsweep_compile hsc_env 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 @@ -1275,6 +1438,83 @@ retainInTopLevelEnvs keep_these hpt , isJust mb_mod_info ] -- --------------------------------------------------------------------------- +-- Typecheck module loops + +{- +See bug #930. This code fixes a long-standing bug in --make. The +problem is that when compiling the modules *inside* a loop, a data +type that is only defined at the top of the loop looks opaque; but +after the loop is done, the structure of the data type becomes +apparent. + +The difficulty is then that two different bits of code have +different notions of what the data type looks like. + +The idea is that after we compile a module which also has an .hs-boot +file, we re-generate the ModDetails for each of the modules that +depends on the .hs-boot file, so that everyone points to the proper +TyCons, Ids etc. defined by the real module, not the boot module. +Fortunately re-generating a ModDetails from a ModIface is easy: the +function TcIface.typecheckIface does exactly that. + +Picking the modules to re-typecheck is slightly tricky. Starting from +the module graph consisting of the modules that have already been +compiled, we reverse the edges (so they point from the imported module +to the importing module), and depth-first-search from the .hs-boot +node. This gives us all the modules that depend transitively on the +.hs-boot module, and those are exactly the modules that we need to +re-typecheck. + +Following this fix, GHC can compile itself with --make -O2. +-} + +reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv +reTypecheckLoop hsc_env ms graph + | not (isBootSummary ms) && + any (\m -> ms_mod m == this_mod && isBootSummary m) graph + = do + let mss = reachableBackwards (ms_mod_name ms) graph + non_boot = filter (not.isBootSummary) mss + debugTraceMsg (hsc_dflags hsc_env) 2 $ + text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot) + typecheckLoop hsc_env (map ms_mod_name non_boot) + | otherwise + = return hsc_env + where + this_mod = ms_mod ms + +typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv +typecheckLoop hsc_env mods = do + new_hpt <- + fixIO $ \new_hpt -> do + let new_hsc_env = hsc_env{ hsc_HPT = new_hpt } + mds <- initIfaceCheck new_hsc_env $ + mapM (typecheckIface . hm_iface) hmis + let new_hpt = addListToUFM old_hpt + (zip mods [ hmi{ hm_details = details } + | (hmi,details) <- zip hmis mds ]) + return new_hpt + return hsc_env{ hsc_HPT = new_hpt } + where + old_hpt = hsc_HPT hsc_env + hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods + +reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary] +reachableBackwards mod summaries + = [ ms | (ms,_,_) <- 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 @@ -1386,7 +1626,7 @@ warnUnnecessarySourceImports dflags sccs = 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)) ----------------------------------------------------------------------------- @@ -1443,7 +1683,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots Nothing -> packageModErr modl Just s -> return s - rootLoc = mkGeneralSrcSpan FSLIT("") + rootLoc = mkGeneralSrcSpan (fsLit "") -- In a root module, the filename is allowed to diverge from the module -- name, so we have to check that there aren't multiple root files @@ -1540,7 +1780,10 @@ summariseFile hsc_env old_summaries file mb_phase maybe_buf if ms_hs_date old_summary == src_timestamp then do -- update the object-file timestamp - obj_timestamp <- getObjTimestamp location False + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) -- #1205 + then getObjTimestamp location False + else return Nothing return old_summary{ ms_obj_date = obj_timestamp } else new_summary @@ -1552,9 +1795,9 @@ summariseFile hsc_env old_summaries file mb_phase maybe_buf let dflags = hsc_dflags hsc_env (dflags', hspp_fn, buf) - <- preprocessFile dflags file mb_phase maybe_buf + <- preprocessFile hsc_env file mb_phase maybe_buf - (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn + (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file -- Make a ModLocation for this file location <- mkHomeModLocation dflags mod_name file @@ -1568,7 +1811,12 @@ summariseFile hsc_env old_summaries file mb_phase maybe_buf Nothing -> getModificationTime file -- getMofificationTime may fail - obj_timestamp <- modificationTimeIfExists (ml_obj_file location) + -- when the user asks to load a source file by name, we only + -- use an object file if -fobject-code is on. See #1205. + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + then modificationTimeIfExists (ml_obj_file location) + else return Nothing return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile, ms_location = location, @@ -1673,13 +1921,14 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc = do -- Preprocess the source file and get its imports -- The dflags' contains the OPTIONS pragmas - (dflags', hspp_fn, buf) <- preprocessFile dflags src_fn Nothing maybe_buf - (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn + (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf + (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn when (mod_name /= wanted_mod) $ throwDyn $ mkPlainErrMsg mod_loc $ - text "file name does not match module name" - <+> quotes (ppr mod_name) + 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 @@ -1702,22 +1951,24 @@ getObjTimestamp location is_boot 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 + local_opts = getOptions dflags buf src_fn -- - (dflags', _errs) <- parseDynamicFlags dflags (map unLoc local_opts) - -- XXX: shouldn't we be reporting the errors? + (dflags', leftovers, warns) <- parseDynamicFlags dflags (map unLoc local_opts) + checkProcessArgsResult leftovers src_fn + handleFlagWarnings dflags' warns let needs_preprocessing @@ -1765,11 +2016,11 @@ multiRootsErr summs@(summ1:_) cyclicModuleErr :: [ModSummary] -> SDoc cyclicModuleErr ms - = hang (ptext SLIT("Module imports form a cycle for modules:")) + = hang (ptext (sLit "Module imports form a cycle for modules:")) 2 (vcat (map show_one ms)) where show_one ms = sep [ show_mod (ms_hsc_src ms) (ms_mod ms), - nest 2 $ ptext SLIT("imports:") <+> + 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) @@ -1809,7 +2060,8 @@ getBindings s = withSession s $ \hsc_env -> 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 { @@ -1902,8 +2154,9 @@ modInfoInstances = minf_instances modInfoIsExportedName :: ModuleInfo -> Name -> Bool modInfoIsExportedName minf name = elemNameSet name (minf_exports minf) -modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified -modInfoPrintUnqualified minf = fmap mkPrintUnqualified (minf_rdr_env minf) +mkPrintUnqualifiedForModule :: 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 @@ -1933,6 +2186,12 @@ lookupGlobalName s name = withSession s $ \hsc_env -> do 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 @@ -1985,7 +2244,7 @@ findModule s mod_name maybe_pkg = withSession s $ \hsc_env -> case res of Found _ m | modulePackageId m /= this_pkg -> return m | otherwise -> throwDyn (CmdLineError (showSDoc $ - text "module" <+> pprModule m <+> + text "module" <+> quotes (ppr (moduleName m)) <+> text "is not loaded")) err -> let msg = cannotFindModule dflags mod_name err in throwDyn (CmdLineError (showSDoc msg))