X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=a04c06c3799877cf2f8a00342f5f982fb1b69b56;hb=38e7ac3ffa32d75c1922e7247a910e06d9957116;hp=4e00c61206fff118bc2099f3157d564bb59ad188;hpb=2c1ea2cedb1a8034b0828e24b554a35f56bb8924;p=ghc-hetmet.git diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 4e00c61..a04c06c 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -11,13 +11,12 @@ module GHC ( Session, defaultErrorHandler, defaultCleanupHandler, - init, initFromArgs, newSession, -- * Flags and settings - DynFlags(..), DynFlag(..), Severity(..), GhcMode(..), HscTarget(..), dopt, + DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt, + GhcMode(..), GhcLink(..), parseDynamicFlags, - initPackages, getSessionDynFlags, setSessionDynFlags, @@ -42,8 +41,11 @@ module GHC ( checkModule, CheckedModule(..), TypecheckedSource, ParsedSource, RenamedSource, + -- * Parsing Haddock comments + parseHaddockComment, + -- * Inspecting the module structure of the program - ModuleGraph, ModSummary(..), ModLocation(..), + ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..), getModuleGraph, isLoaded, topSortModuleGraph, @@ -65,6 +67,7 @@ module GHC ( -- * Interactive evaluation getBindings, getPrintUnqual, + findModule, #ifdef GHCI setContext, getContext, getNamesInScope, @@ -74,21 +77,31 @@ module GHC ( exprType, typeKind, parseName, - RunResult(..), + RunResult(..), ResumeHandle, runStmt, + resume, showModule, - compileExpr, HValue, + isModuleInterpreted, + compileExpr, HValue, dynCompileExpr, lookupName, + obtainTerm, obtainTerm1, + ModBreaks(..), BreakIndex, + BreakInfo(breakInfo_number, breakInfo_module), + modInfoModBreaks, #endif -- * Abstract syntax elements + -- ** Packages + PackageId, + -- ** Modules - Module, mkModule, pprModule, + Module, mkModule, pprModule, moduleName, modulePackageId, + ModuleName, mkModuleName, moduleNameString, -- ** Names Name, - nameModule, nameParent_maybe, pprParenSymName, nameSrcLoc, + nameModule, pprParenSymName, nameSrcLoc, NamedThing(..), RdrName(Qual,Unqual), @@ -106,7 +119,8 @@ module GHC ( TyCon, tyConTyVars, tyConDataCons, tyConArity, isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon, - synTyConDefn, synTyConRhs, + isOpenTyCon, + synTyConDefn, synTyConType, synTyConResKind, -- ** Type variables TyVar, @@ -129,7 +143,8 @@ module GHC ( instanceDFunId, pprInstance, pprInstanceHdr, -- ** Types and Kinds - Type, dropForAlls, splitForAllTys, funResultTy, pprParendType, + Type, dropForAlls, splitForAllTys, funResultTy, + pprParendType, pprTypeApp, Kind, PredType, ThetaType, pprThetaArrow, @@ -161,89 +176,82 @@ module GHC ( ToDo: * 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? -} #include "HsVersions.h" #ifdef GHCI -import qualified Linker -import Linker ( HValue, extendLinkEnv ) +import RtClosureInspect ( cvObtainTerm, Term ) import TcRnDriver ( tcRnLookupRdrName, tcRnGetInfo, tcRnLookupName, getModuleExports ) -import RdrName ( plusGlobalRdrEnv, Provenance(..), - ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), - mkGlobalRdrEnv ) -import HscMain ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType ) -import Type ( tidyType ) import VarEnv ( emptyTidyEnv ) -import GHC.Exts ( unsafeCoerce# ) +import GHC.Exts ( unsafeCoerce#, Ptr ) +import Foreign.StablePtr( deRefStablePtr, StablePtr, newStablePtr, freeStablePtr ) +import Foreign ( poke ) +import qualified Linker + +import Data.Dynamic ( Dynamic ) +import Linker ( HValue, getHValue, extendLinkEnv ) + +import ByteCodeInstr +import DebuggerTys +import IdInfo +import HscMain ( hscParseIdentifier, hscTcExpr, hscKcType, hscStmt ) #endif -import Packages ( initPackages ) -import NameSet ( NameSet, nameSetToList, elemNameSet ) -import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..), - globalRdrEnvElts, extendGlobalRdrEnv, - emptyGlobalRdrEnv ) -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 Packages +import NameSet +import RdrName +import HsSyn +import Type hiding (typeKind) +import Id +import Var hiding (setIdType) 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 TyCon +import Class +import FunDeps +import DataCon +import Name hiding ( varName ) import OccName ( parenSymOcc ) -import NameEnv ( nameEnvElts ) +import NameEnv import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr ) import SrcLoc import DriverPipeline import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase ) import HeaderInfo ( getImports, getOptions ) -import Packages ( isHomePackage ) import Finder -import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) ) +import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) ) import HscTypes import DynFlags -import SysTools ( initSysTools, cleanTempFiles ) +import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept, + cleanTempDirs ) import Module +import UniqFM +import PackageConfig import FiniteMap import Panic import Digraph -import Bag ( unitBag ) +import Bag ( unitBag, listToBag ) import ErrUtils ( Severity(..), showPass, fatalErrorMsg, debugTraceMsg, - mkPlainErrMsg, printBagOfErrors, printErrorsAndWarnings ) + mkPlainErrMsg, printBagOfErrors, printBagOfWarnings, + WarnMsg ) import qualified ErrUtils import Util import StringBuffer ( StringBuffer, hGetStringBuffer ) import Outputable -import SysTools ( cleanTempFilesExcept ) import BasicTypes import TcType ( tcSplitSigmaTy, isDictTy ) import Maybes ( expectJust, mapCatMaybes ) +import HaddockParse +import HaddockLex ( tokenise ) import Control.Concurrent import System.Directory ( getModificationTime, doesFileExist ) -import Data.Maybe ( isJust, isNothing ) -import Data.List ( partition, nub ) +import Data.Maybe +import Data.List import qualified Data.List as List -import Control.Monad ( unless, when ) +import Control.Monad import System.Exit ( exitWith, ExitCode(..) ) import System.Time ( ClockTime ) import Control.Exception as Exception hiding (handle) @@ -303,56 +311,34 @@ defaultErrorHandler dflags inner = -- handling, but still get the ordinary cleanup behaviour. defaultCleanupHandler :: DynFlags -> IO a -> IO a defaultCleanupHandler dflags inner = - -- make sure we clean up after ourselves - later (unless (dopt Opt_KeepTmpFiles dflags) $ - cleanTempFiles dflags) - -- exceptions will be blocked while we clean the temporary files, - -- so there shouldn't be any difficulty if we receive further - -- signals. - inner - - --- | Initialises GHC. This must be done /once/ only. Takes the --- TopDir path without the '-B' prefix. - -init :: Maybe String -> IO () -init mbMinusB = do - -- catch ^C - main_thread <- myThreadId - putMVar interruptTargetThread [main_thread] - installSignalHandlers - - dflags0 <- initSysTools mbMinusB defaultDynFlags - writeIORef v_initDynFlags dflags0 - --- | 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 - -- calls to newSession. + -- make sure we clean up after ourselves + later (do cleanTempFiles dflags + cleanTempDirs dflags + ) + -- exceptions will be blocked while we clean the temporary files, + -- so there shouldn't be any difficulty if we receive further + -- signals. + inner + + +#if defined(GHCI) +GLOBAL_VAR(v_bkptLinkEnv, [], [(Name, HValue)]) + -- stores the current breakpoint handler to help setContext to + -- restore it after a context change +#endif -- | 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 --- code". -newSession :: GhcMode -> IO Session -newSession mode = do - dflags0 <- readIORef v_initDynFlags - dflags <- initDynFlags dflags0 - env <- newHscEnv dflags{ ghcMode=mode } +newSession :: Maybe FilePath -> IO Session +newSession mb_top_dir = do + -- catch ^C + main_thread <- myThreadId + modifyMVar_ interruptTargetThread (return . (main_thread :)) + installSignalHandlers + + dflags0 <- initSysTools mb_top_dir defaultDynFlags + dflags <- initDynFlags dflags0 + env <- newHscEnv dflags ref <- newIORef env return (Session ref) @@ -374,9 +360,23 @@ modifySession (Session ref) f = do h <- readIORef ref; writeIORef ref $! f h getSessionDynFlags :: Session -> IO DynFlags getSessionDynFlags s = withSession s (return . hsc_dflags) --- | Updates the DynFlags in a Session -setSessionDynFlags :: Session -> DynFlags -> IO () -setSessionDynFlags s dflags = modifySession s (\h -> h{ hsc_dflags = dflags }) +-- | Updates the DynFlags in a Session. This also reads +-- the package database (unless it has already been read), +-- and prepares the compilers knowledge about packages. It +-- can be called again to load new packages: just add new +-- package flags to (packageFlags dflags). +-- +-- Returns a list of new packages that may need to be linked in using +-- the dynamic linker (see 'linkPackages') as a result of new package +-- flags. If you are not doing linking or doing static linking, you +-- can ignore the list of packages returned. +-- +setSessionDynFlags :: Session -> DynFlags -> IO [PackageId] +setSessionDynFlags (Session ref) dflags = do + hsc_env <- readIORef ref + (dflags', preload) <- initPackages dflags + writeIORef ref $! hsc_env{ hsc_dflags = dflags' } + return preload -- | If there is no -o option, guess the name of target executable -- by using top-level source file name as a base. @@ -448,7 +448,7 @@ guessTarget file Nothing if exists then return (Target (TargetFile lhs_file Nothing) Nothing) else do - return (Target (TargetModule (mkModule file)) Nothing) + return (Target (TargetModule (mkModuleName file)) Nothing) where hs_file = file `joinFileExt` "hs" lhs_file = file `joinFileExt` "lhs" @@ -479,11 +479,17 @@ setGlobalTypeScope session ids hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids } -- ----------------------------------------------------------------------------- +-- Parsing Haddock comments + +parseHaddockComment :: String -> Either String (HsDoc RdrName) +parseHaddockComment string = parseHaddockParagraphs (tokenise string) + +-- ----------------------------------------------------------------------------- -- Loading the program -- Perform a dependency analysis starting from the current targets -- and update the session with the new module graph. -depanal :: Session -> [Module] -> Bool -> IO (Maybe ModuleGraph) +depanal :: Session -> [ModuleName] -> Bool -> IO (Maybe ModuleGraph) depanal (Session ref) excluded_mods allow_dup_roots = do hsc_env <- readIORef ref let @@ -493,10 +499,9 @@ depanal (Session ref) excluded_mods allow_dup_roots = do 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))]) + debugTraceMsg dflags 2 (hcat [ + text "Chasing modules from: ", + hcat (punctuate comma (map pprTarget targets))]) r <- downsweep hsc_env old_graph excluded_mods allow_dup_roots case r of @@ -522,8 +527,8 @@ data ErrMsg = ErrMsg { data LoadHowMuch = LoadAllTargets - | LoadUpTo Module - | LoadDependenciesOf Module + | LoadUpTo ModuleName + | LoadDependenciesOf ModuleName -- | Try to load the program. If a Module is supplied, then just -- attempt to load up to this target. If no Module is supplied, @@ -552,10 +557,11 @@ load2 s@(Session ref) how_much mod_graph = do -- 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)] + 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 s `elem` all_home_mods)] + not (ms_mod_name s `elem` all_home_mods)] #endif ASSERT( null bad_boot_mods ) return () @@ -567,10 +573,14 @@ load2 s@(Session ref) how_much mod_graph = do let mg2_with_srcimps :: [SCC ModSummary] mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing + -- If we can determine that any of the {-# SOURCE #-} imports + -- are definitely unnecessary, then emit a warning. + warnUnnecessarySourceImports dflags mg2_with_srcimps + + let -- 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 + = checkStability hpt1 mg2_with_srcimps all_home_mods -- prune bits of the HPT which are definitely redundant now, -- to save space. @@ -586,7 +596,7 @@ load2 s@(Session ref) how_much mod_graph = do -- 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 hmi <- [lookupUFM pruned_hpt m], Just linkable <- [hm_linkable hmi] ] unload hsc_env stable_linkables @@ -623,7 +633,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 ms == mod; _ -> False ) + AcyclicSCC ms -> ms_mod_name ms == mod; _ -> False ) List.init partial_mg0 | otherwise = partial_mg0 @@ -631,9 +641,9 @@ load2 s@(Session ref) how_much mod_graph = do 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 ] ] + ms_mod_name ms `elem` stable_obj++stable_bco, + ms_mod_name ms `notElem` [ ms_mod_name ms' | + AcyclicSCC ms' <- partial_mg ] ] mg = stable_mg ++ partial_mg @@ -641,6 +651,8 @@ load2 s@(Session ref) how_much mod_graph = do let cleanup = cleanTempFilesExcept dflags (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps)) + debugTraceMsg dflags 2 (hang (text "Ready for upsweep") + 2 (ppr mg)) (upsweep_ok, hsc_env1, modsUpswept) <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable }) pruned_hpt stable_mods cleanup mg @@ -676,13 +688,16 @@ load2 s@(Session ref) how_much mod_graph = do 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) $ - 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.")) + when (ghcLink dflags == LinkBinary + && 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 " ++ + moduleNameString (moduleName main_mod) ++ " module.") -- link everything together - linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env1) + linkresult <- link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) loadFinish Succeeded linkresult ref hsc_env1 @@ -701,7 +716,7 @@ load2 s@(Session ref) how_much mod_graph = do = filter ((`notElem` mods_to_zap_names).ms_mod) modsDone - let hpt4 = retainInTopLevelEnvs (map ms_mod mods_to_keep) + let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) (hsc_HPT hsc_env1) -- Clean up after ourselves @@ -709,10 +724,10 @@ load2 s@(Session ref) how_much mod_graph = do -- there should be no Nothings where linkables should be, now ASSERT(all (isJust.hm_linkable) - (moduleEnvElts (hsc_HPT hsc_env))) do + (eltsUFM (hsc_HPT hsc_env))) do -- Link everything together - linkresult <- link ghci_mode dflags False hpt4 + linkresult <- link (ghcLink dflags) dflags False hpt4 let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 } loadFinish Failed linkresult ref hsc_env4 @@ -760,7 +775,8 @@ data CheckedModule = -- fields within CheckedModule. type ParsedSource = Located (HsModule RdrName) -type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name]) +type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], + Maybe (HsDoc Name), HaddockModInfo Name) type TypecheckedSource = LHsBinds Id -- NOTE: @@ -780,7 +796,7 @@ type TypecheckedSource = LHsBinds Id -- 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 -> ModuleName -> IO (Maybe CheckedModule) checkModule session@(Session ref) mod = do -- load up the dependencies first r <- load session (LoadDependenciesOf mod) @@ -789,7 +805,7 @@ checkModule session@(Session ref) mod = 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 + 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 @@ -805,9 +821,13 @@ checkModule session@(Session ref) mod = do (Just (tc_binds, rdr_env, details))) -> do let minf = ModuleInfo { minf_type_env = md_types details, - minf_exports = md_exports details, + minf_exports = availsToNameSet $ + md_exports details, minf_rdr_env = Just rdr_env, minf_instances = md_insts details +#ifdef GHCI + ,minf_modBreaks = emptyModBreaks +#endif } return (Just (CheckedModule { parsedSource = parsed, @@ -820,15 +840,13 @@ checkModule session@(Session ref) mod = do unload :: HscEnv -> [Linkable] -> IO () unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' - = case ghcMode (hsc_dflags hsc_env) of - BatchCompile -> return () - JustTypecheck -> return () + = case ghcLink (hsc_dflags hsc_env) of #ifdef GHCI - Interactive -> Linker.unload (hsc_dflags hsc_env) stable_linkables + LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables #else - Interactive -> panic "unload: no interpreter" + LinkInMemory -> panic "unload: no interpreter" #endif - other -> panic "unload: strange mode" + other -> return () -- ----------------------------------------------------------------------------- -- checkStability @@ -845,9 +863,6 @@ unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' 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. @@ -866,7 +881,7 @@ unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' These properties embody the following ideas: - - if a module is stable: + - if a module is stable, then: - if it has been compiled in a previous pass (present in HPT) then it does not need to be compiled or re-linked. - if it has not been compiled in a previous pass, @@ -885,9 +900,9 @@ unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' checkStability :: HomePackageTable -- HPT from last compilation -> [SCC ModSummary] -- current module graph (cyclic) - -> [Module] -- all home modules - -> ([Module], -- stableObject - [Module]) -- stableBCO + -> [ModuleName] -- all home modules + -> ([ModuleName], -- stableObject + [ModuleName]) -- stableBCO checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs where @@ -897,7 +912,7 @@ checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs | otherwise = (stable_obj, stable_bco) where scc = flattenSCC scc0 - scc_mods = map ms_mod scc + scc_mods = map ms_mod_name scc home_module m = m `elem` all_home_mods && m `notElem` scc_mods scc_allimps = nub (filter home_module (concatMap ms_allimps scc)) @@ -919,7 +934,7 @@ checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs && same_as_prev t | otherwise = False where - same_as_prev t = case lookupModuleEnv hpt (ms_mod ms) of + same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of Just hmi | Just l <- hm_linkable hmi -> isObjectLinkable l && t == linkableTime l _other -> True @@ -931,13 +946,13 @@ checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs -- make's behaviour. bco_ok ms - = case lookupModuleEnv hpt (ms_mod ms) of + = case lookupUFM hpt (ms_mod_name 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 :: ModSummary -> [ModuleName] ms_allimps ms = map unLoc (ms_srcimps ms ++ ms_imps ms) -- ----------------------------------------------------------------------------- @@ -958,23 +973,23 @@ ms_allimps ms = map unLoc (ms_srcimps ms ++ ms_imps ms) pruneHomePackageTable :: HomePackageTable -> [ModSummary] - -> ([Module],[Module]) + -> ([ModuleName],[ModuleName]) -> HomePackageTable pruneHomePackageTable hpt summ (stable_obj, stable_bco) - = mapModuleEnv prune hpt + = mapUFM prune hpt where prune hmi | is_stable modl = hmi' | otherwise = hmi'{ hm_details = emptyModDetails } where - modl = mi_module (hm_iface hmi) + modl = moduleName (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) + where ms = expectJust "prune" (lookupUFM ms_map modl) - ms_map = mkModuleEnv [(ms_mod ms, ms) | ms <- summ] + ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ] is_stable m = m `elem` stable_obj || m `elem` stable_bco @@ -1011,7 +1026,7 @@ findPartiallyCompletedCycles modsDone theGraph upsweep :: HscEnv -- Includes initially-empty HPT -> HomePackageTable -- HPT from last time round (pruned) - -> ([Module],[Module]) -- stable modules (see checkStability) + -> ([ModuleName],[ModuleName]) -- stable modules (see checkStability) -> IO () -- How to clean up unwanted tmp files -> [SCC ModSummary] -- Mods to do (the worklist) -> IO (SuccessFlag, @@ -1044,11 +1059,10 @@ upsweep' hsc_env old_hpt stable_mods cleanup case mb_mod_info of Nothing -> return (Failed, hsc_env, []) Just mod_info -> do - { let this_mod = ms_mod mod + { let this_mod = ms_mod_name mod -- Add new info to hsc_env - hpt1 = extendModuleEnv (hsc_HPT hsc_env) - this_mod mod_info + hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info hsc_env1 = hsc_env { hsc_HPT = hpt1 } -- Space-saving: delete the old HPT entry @@ -1058,7 +1072,7 @@ upsweep' hsc_env old_hpt stable_mods cleanup -- main Haskell source file. Deleting it -- would force .. (what?? --SDM) old_hpt1 | isBootSummary mod = old_hpt - | otherwise = delModuleEnv old_hpt this_mod + | otherwise = delFromUFM old_hpt this_mod ; (restOK, hsc_env2, modOKs) <- upsweep' hsc_env1 old_hpt1 stable_mods cleanup @@ -1071,101 +1085,140 @@ upsweep' hsc_env old_hpt stable_mods cleanup -- successful. If no compilation happened, return the old Linkable. upsweep_mod :: HscEnv -> HomePackageTable - -> ([Module],[Module]) + -> ([ModuleName],[ModuleName]) -> ModSummary -> Int -- index of module -> Int -- total number of modules -> IO (Maybe HomeModInfo) -- Nothing => Failed upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods - = do - let + = let + this_mod_name = ms_mod_name summary 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 + is_stable_obj = this_mod_name `elem` stable_obj + is_stable_bco = this_mod_name `elem` stable_bco + + old_hmi = lookupUFM old_hpt this_mod_name + + -- We're using the dflags for this module now, obtained by + -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas. + dflags = ms_hspp_opts summary + prevailing_target = hscTarget (hsc_dflags hsc_env) + local_target = hscTarget dflags + + -- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that + -- we don't do anything dodgy: these should only work to change + -- from -fvia-C to -fasm and vice-versa, otherwise we could + -- end up trying to link object code to byte code. + target = if prevailing_target /= local_target + && (not (isObjectTarget prevailing_target) + || not (isObjectTarget local_target)) + then prevailing_target + else local_target + + -- store the corrected hscTarget into the summary + summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } } + + -- The old interface is ok if + -- a) we're compiling a source file, and the old HPT + -- 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 + = case old_hmi of + Nothing -> Nothing + Just hm_info | isBootSummary summary -> Just iface + | not (mi_boot iface) -> Just iface + | otherwise -> Nothing + where + iface = hm_iface hm_info + 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 + compile_it = upsweep_compile hsc_env old_hpt this_mod_name + 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 + + in + case target of + + _any + -- Regardless of whether we're generating object code or + -- byte code, we can always use an existing object file + -- if it is *stable* (see checkStability). + | is_stable_obj, isJust old_hmi -> + return old_hmi -- object is stable, and we have an entry in the -- old HPT: nothing to do - | is_stable_obj, isNothing old_hmi -> do - linkable <- - findObjectLinkable this_mod obj_fn + | is_stable_obj, isNothing old_hmi -> do + linkable <- findObjectLinkable this_mod obj_fn (expectJust "upseep1" mb_obj_date) - compile_it (Just linkable) + 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 + HscInterpreted + | is_stable_bco -> + ASSERT(isJust old_hmi) -- must be in the old_hpt + return old_hmi -- BCO is stable: nothing to do - | Just hmi <- old_hmi, - Just l <- hm_linkable hmi, not (isObjectLinkable l), - linkableTime l >= ms_hs_date summary -> - compile_it (Just l) + | 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 + | 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 + -- When generating object code, if there's an up-to-date + -- object file on the disk, then we can use it. + -- However, if the object file is new (compared to any + -- linkable we had from a previous compilation), then we + -- must discard any in-memory interface, because this + -- means the user has compiled the source file + -- separately and generated a new interface, that we must + -- read from the disk. + -- + obj | isObjectTarget obj, + Just obj_date <- mb_obj_date, obj_date >= hs_date -> do + case old_hmi of + Just hmi + | Just l <- hm_linkable hmi, + isObjectLinkable l && linkableTime l == obj_date + -> compile_it (Just l) + _otherwise -> do + linkable <- findObjectLinkable this_mod obj_fn obj_date + compile_it_discard_iface (Just linkable) + + _otherwise -> + compile_it Nothing + -- Run hsc to compile a module upsweep_compile hsc_env old_hpt this_mod summary mod_index nmods - mb_old_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 - -- 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 - = case lookupModuleEnv old_hpt this_mod of - Nothing -> Nothing - Just hm_info | isBootSummary summary -> Just iface - | not (mi_boot iface) -> Just iface - | otherwise -> Nothing - where - iface = hm_iface hm_info - - compresult <- compile hsc_env summary mb_old_linkable mb_old_iface + mb_old_iface + mb_old_linkable + = do + compresult <- compile hsc_env summary mb_old_linkable mb_old_iface mod_index nmods - case compresult of + case compresult of -- Compilation failed. Compile may still have updated the PCS, tho. CompErrs -> return Nothing @@ -1180,11 +1233,11 @@ upsweep_compile hsc_env old_hpt this_mod summary -- Filter modules in the HPT -retainInTopLevelEnvs :: [Module] -> HomePackageTable -> HomePackageTable +retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable retainInTopLevelEnvs keep_these hpt - = mkModuleEnv [ (mod, expectJust "retain" mb_mod_info) + = listToUFM [ (mod, expectJust "retain" mb_mod_info) | mod <- keep_these - , let mb_mod_info = lookupModuleEnv hpt mod + , let mb_mod_info = lookupUFM hpt mod , isJust mb_mod_info ] -- --------------------------------------------------------------------------- @@ -1193,7 +1246,7 @@ retainInTopLevelEnvs keep_these hpt topSortModuleGraph :: Bool -- Drop hi-boot nodes? (see below) -> [ModSummary] - -> Maybe Module + -> Maybe ModuleName -> [SCC ModSummary] -- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes -- The resulting list of strongly-connected-components is in topologically @@ -1226,7 +1279,7 @@ topSortModuleGraph drop_hs_boot_nodes summaries (Just mod) | otherwise = throwDyn (ProgramError "module does not exist") moduleGraphNodes :: Bool -> [ModSummary] - -> ([(ModSummary, Int, [Int])], HscSource -> Module -> Maybe Int) + -> ([(ModSummary, Int, [Int])], HscSource -> ModuleName -> Maybe Int) moduleGraphNodes drop_hs_boot_nodes summaries = (nodes, lookup_key) where -- Drop hs-boot nodes by using HsSrcFile as the key @@ -1235,31 +1288,48 @@ moduleGraphNodes drop_hs_boot_nodes summaries = (nodes, lookup_key) -- We use integers as the keys for the SCC algorithm nodes :: [(ModSummary, Int, [Int])] - nodes = [(s, expectJust "topSort" (lookup_key (ms_hsc_src s) (ms_mod s)), + nodes = [(s, expectJust "topSort" $ + lookup_key (ms_hsc_src s) (ms_mod_name s), out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++ - out_edge_keys HsSrcFile (map unLoc (ms_imps s)) ) + out_edge_keys HsSrcFile (map unLoc (ms_imps s)) ++ + (-- see [boot-edges] below + if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile + then [] + else case lookup_key HsBootFile (ms_mod_name s) of + Nothing -> [] + Just k -> [k]) + ) | s <- summaries , not (isBootSummary s && drop_hs_boot_nodes) ] -- Drop the hi-boot ones if told to do so + -- [boot-edges] if this is a .hs and there is an equivalent + -- .hs-boot, add a link from the former to the latter. This + -- has the effect of detecting bogus cases where the .hs-boot + -- depends on the .hs, by introducing a cycle. Additionally, + -- it ensures that we will always process the .hs-boot before + -- the .hs, and so the HomePackageTable will always have the + -- most up to date information. + key_map :: NodeMap Int - key_map = listToFM ([(ms_mod s, ms_hsc_src s) | s <- summaries] + key_map = listToFM ([(moduleName (ms_mod s), ms_hsc_src s) + | s <- summaries] `zip` [1..]) - lookup_key :: HscSource -> Module -> Maybe Int + lookup_key :: HscSource -> ModuleName -> Maybe Int lookup_key hs_src mod = lookupFM key_map (mod, hs_src) - out_edge_keys :: HscSource -> [Module] -> [Int] + out_edge_keys :: HscSource -> [ModuleName] -> [Int] out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms -- If we want keep_hi_boot_nodes, then we do lookup_key with -- the IsBootInterface parameter True; else False -type NodeKey = (Module, HscSource) -- The nodes of the graph are +type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are type NodeMap a = FiniteMap NodeKey a -- keyed by (mod, src_file_type) pairs msKey :: ModSummary -> NodeKey -msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (mod,boot) +msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot) mkNodeMap :: [ModSummary] -> NodeMap ModSummary mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries] @@ -1267,6 +1337,27 @@ mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries] nodeMapElts :: NodeMap a -> [a] nodeMapElts = eltsFM +ms_mod_name :: ModSummary -> ModuleName +ms_mod_name = moduleName . ms_mod + +-- If there are {-# SOURCE #-} imports between strongly connected +-- components in the topological sort, then those imports can +-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE +-- were necessary, then the edge would be part of a cycle. +warnUnnecessarySourceImports :: DynFlags -> [SCC ModSummary] -> IO () +warnUnnecessarySourceImports dflags sccs = + printBagOfWarnings dflags (listToBag (concat (map (check.flattenSCC) sccs))) + where check ms = + let mods_in_this_cycle = map ms_mod_name ms in + [ warn m i | m <- ms, i <- ms_srcimps m, + unLoc i `notElem` mods_in_this_cycle ] + + warn :: ModSummary -> Located ModuleName -> WarnMsg + warn ms (L loc mod) = + mkPlainErrMsg loc + (ptext SLIT("Warning: {-# SOURCE #-} unnecessary in import of ") + <+> quotes (ppr mod)) + ----------------------------------------------------------------------------- -- Downsweep (dependency analysis) @@ -1284,7 +1375,7 @@ nodeMapElts = eltsFM downsweep :: HscEnv -> [ModSummary] -- Old summaries - -> [Module] -- Ignore dependencies on these; treat + -> [ModuleName] -- Ignore dependencies on these; treat -- them as if they were package modules -> Bool -- True <=> allow multiple targets to have -- the same module name; this is @@ -1336,7 +1427,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots dup_roots :: [[ModSummary]] -- Each at least of length 2 dup_roots = filterOut isSingleton (nodeMapElts root_map) - loop :: [(Located Module,IsBootInterface)] + loop :: [(Located ModuleName,IsBootInterface)] -- Work list: process these modules -> NodeMap [ModSummary] -- Visited set; the range is a list because @@ -1365,7 +1456,7 @@ mkRootMap :: [ModSummary] -> NodeMap [ModSummary] mkRootMap summaries = addListToFM_C (++) emptyFM [ (msKey s, [s]) | s <- summaries ] -msDeps :: ModSummary -> [(Located Module, IsBootInterface)] +msDeps :: ModSummary -> [(Located ModuleName, 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 @@ -1432,14 +1523,14 @@ summariseFile hsc_env old_summaries file mb_phase maybe_buf (dflags', hspp_fn, buf) <- preprocessFile dflags file mb_phase maybe_buf - (srcimps,the_imps, L _ mod) <- getImports dflags' buf hspp_fn + (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn -- Make a ModLocation for this file - location <- mkHomeModLocation dflags mod file + location <- mkHomeModLocation dflags mod_name file -- Tell the Finder cache where it is, so that subsequent calls -- to findModule will find it, even if it's not on any search path - addHomeModuleToFinder hsc_env mod location + mod <- addHomeModuleToFinder hsc_env mod_name location src_timestamp <- case maybe_buf of Just (_,t) -> return t @@ -1469,9 +1560,9 @@ summariseModule :: HscEnv -> NodeMap ModSummary -- Map of old summaries -> IsBootInterface -- True <=> a {-# SOURCE #-} import - -> Located Module -- Imported module to be summarised + -> Located ModuleName -- Imported module to be summarised -> Maybe (StringBuffer, ClockTime) - -> [Module] -- Modules to exclude + -> [ModuleName] -- Modules to exclude -> IO (Maybe ModSummary) -- Its new summary summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf excl_mods @@ -1508,9 +1599,8 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc 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 + -- source changed: re-summarise. + new_summary location (ms_mod old_summary) src_fn src_timestamp find_it = do -- Don't use the Finder's cache this time. If the module was @@ -1518,17 +1608,22 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc -- 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-} + found <- findImportedModule hsc_env wanted_mod Nothing case found of - Found location pkg - | not (isHomePackage pkg) -> return Nothing - -- Drop external-pkg - | isJust (ml_hs_file location) -> just_found location + Found location mod + | isJust (ml_hs_file location) -> -- Home package + just_found location mod + | otherwise -> + -- Drop external-pkg + ASSERT(modulePackageId mod /= thisPackage dflags) + return Nothing + where + err -> noModError dflags loc wanted_mod err -- Not found - just_found location = do + just_found location mod = 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 @@ -1540,10 +1635,10 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc maybe_t <- modificationTimeIfExists src_fn case maybe_t of Nothing -> noHsFileErr loc src_fn - Just t -> new_summary location' src_fn t + Just t -> new_summary location' mod src_fn t - new_summary location src_fn src_timestamp + new_summary location mod src_fn src_timestamp = do -- Preprocess the source file and get its imports -- The dflags' contains the OPTIONS pragmas @@ -1558,7 +1653,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc -- Find the object timestamp, and return the summary obj_timestamp <- getObjTimestamp location is_boot - return (Just ( ModSummary { ms_mod = wanted_mod, + return (Just ( ModSummary { ms_mod = mod, ms_hsc_src = hsc_src, ms_location = location, ms_hspp_file = hspp_fn, @@ -1610,10 +1705,10 @@ preprocessFile dflags src_fn mb_phase (Just (buf, time)) -- Error messages ----------------------------------------------------------------------------- -noModError :: DynFlags -> SrcSpan -> Module -> FindResult -> IO ab +noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab -- ToDo: we don't have a proper line number for this error noModError dflags loc wanted_mod err - = throwDyn $ mkPlainErrMsg loc $ cantFindError dflags wanted_mod err + = throwDyn $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err noHsFileErr loc path = throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path @@ -1650,8 +1745,7 @@ cyclicModuleErr ms -- Note: if you change the working directory, you should also unload -- the current program (set targets to empty, followed by load). workingDirectoryChanged :: Session -> IO () -workingDirectoryChanged s = withSession s $ \hsc_env -> - flushFinderCache (hsc_FC hsc_env) +workingDirectoryChanged s = withSession s $ flushFinderCaches -- ----------------------------------------------------------------------------- -- inspecting the session @@ -1660,9 +1754,9 @@ workingDirectoryChanged s = withSession s $ \hsc_env -> getModuleGraph :: Session -> IO ModuleGraph -- ToDo: DiGraph ModSummary getModuleGraph s = withSession s (return . hsc_mod_graph) -isLoaded :: Session -> Module -> IO Bool +isLoaded :: Session -> ModuleName -> IO Bool isLoaded s m = withSession s $ \hsc_env -> - return $! isJust (lookupModuleEnv (hsc_HPT hsc_env) m) + return $! isJust (lookupUFM (hsc_HPT hsc_env) m) getBindings :: Session -> IO [TyThing] getBindings s = withSession s (return . nameEnvElts . ic_type_env . hsc_IC) @@ -1673,9 +1767,12 @@ getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC) -- | Container for information about a 'Module'. data ModuleInfo = ModuleInfo { minf_type_env :: TypeEnv, - minf_exports :: NameSet, + minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails? minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod minf_instances :: [Instance] +#ifdef GHCI + ,minf_modBreaks :: ModBreaks +#endif -- ToDo: this should really contain the ModIface too } -- We don't want HomeModInfo here, because a ModuleInfo applies @@ -1686,7 +1783,7 @@ 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 + then getHomeModuleInfo hsc_env (moduleName mdl) else do {- if isHomeModule (hsc_dflags hsc_env) mdl then return Nothing @@ -1699,22 +1796,23 @@ getModuleInfo s mdl = withSession s $ \hsc_env -> do getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) getPackageModuleInfo hsc_env mdl = do #ifdef GHCI - (_msgs, mb_names) <- getModuleExports hsc_env mdl - case mb_names of + (_msgs, mb_avails) <- getModuleExports hsc_env mdl + case mb_avails of Nothing -> return Nothing - Just names -> do + Just avails -> do eps <- readIORef (hsc_EPS hsc_env) let + names = availsToNameSet avails pte = eps_PTE eps - n_list = nameSetToList names - tys = [ ty | name <- n_list, + tys = [ ty | name <- concatMap availNames avails, 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" + minf_rdr_env = Just $! nameSetToGlobalRdrEnv names (moduleName mdl), + minf_instances = error "getModuleInfo: instances for package module unimplemented", + minf_modBreaks = emptyModBreaks })) #else -- bogusly different for non-GHCI (ToDo) @@ -1722,15 +1820,18 @@ getPackageModuleInfo hsc_env mdl = do #endif getHomeModuleInfo hsc_env mdl = - case lookupModuleEnv (hsc_HPT hsc_env) mdl of + case lookupUFM (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_exports = availsToNameSet (md_exports details), minf_rdr_env = mi_globals $! hm_iface hmi, minf_instances = md_insts details +#ifdef GHCI + ,minf_modBreaks = md_modBreaks details +#endif })) -- | The list of top-level entities defined in a module @@ -1753,7 +1854,7 @@ modInfoIsExportedName :: ModuleInfo -> Name -> Bool modInfoIsExportedName minf name = elemNameSet name (minf_exports minf) modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified -modInfoPrintUnqualified minf = fmap unQualInScope (minf_rdr_env minf) +modInfoPrintUnqualified minf = fmap mkPrintUnqualified (minf_rdr_env minf) modInfoLookupName :: Session -> ModuleInfo -> Name -> IO (Maybe TyThing) modInfoLookupName s minf name = withSession s $ \hsc_env -> do @@ -1761,7 +1862,12 @@ modInfoLookupName s minf name = withSession s $ \hsc_env -> do Just tyThing -> return (Just tyThing) Nothing -> do eps <- readIORef (hsc_EPS hsc_env) - return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name + return $! lookupType (hsc_dflags hsc_env) + (hsc_HPT hsc_env) (eps_PTE eps) name + +#ifdef GHCI +modInfoModBreaks = minf_modBreaks +#endif isDictonaryId :: Id -> Bool isDictonaryId id @@ -1774,7 +1880,8 @@ isDictonaryId id 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 + return $! lookupType (hsc_dflags hsc_env) + (hsc_HPT hsc_env) (eps_PTE eps) name -- ----------------------------------------------------------------------------- -- Misc exported utils @@ -1811,6 +1918,31 @@ getTokenStream :: Session -> Module -> IO [Located Token] -- ----------------------------------------------------------------------------- -- Interactive evaluation +-- | Takes a 'ModuleName' and possibly a 'PackageId', and consults the +-- filesystem and package database to find the corresponding 'Module', +-- using the algorithm that is used for an @import@ declaration. +findModule :: Session -> ModuleName -> Maybe PackageId -> IO Module +findModule s mod_name maybe_pkg = withSession s $ \hsc_env -> + findModule' hsc_env mod_name maybe_pkg + +findModule' hsc_env mod_name maybe_pkg = + let + dflags = hsc_dflags hsc_env + hpt = hsc_HPT hsc_env + this_pkg = thisPackage dflags + in + case lookupUFM hpt mod_name of + Just mod_info -> return (mi_module (hm_iface mod_info)) + _not_a_home_module -> do + res <- findImportedModule hsc_env mod_name maybe_pkg + case res of + Found _ m | modulePackageId m /= this_pkg -> return m + | otherwise -> throwDyn (CmdLineError (showSDoc $ + text "module" <+> pprModule m <+> + text "is not loaded")) + err -> let msg = cannotFindModule dflags mod_name err in + throwDyn (CmdLineError (showSDoc msg)) + #ifdef GHCI -- | Set the interactive evaluation context. @@ -1822,67 +1954,53 @@ setContext :: Session -> [Module] -- entire top level scope of these modules -> [Module] -- exports only of these modules -> IO () -setContext (Session ref) toplevs exports = do +setContext sess@(Session ref) toplev_mods export_mods = do hsc_env <- readIORef ref let old_ic = hsc_IC hsc_env hpt = hsc_HPT hsc_env - - mapM_ (checkModuleExists hsc_env hpt) exports - export_env <- mkExportEnv hsc_env exports - toplev_envs <- mapM (mkTopLevEnv hpt) toplevs + -- + export_env <- mkExportEnv hsc_env export_mods + toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods let all_env = foldr plusGlobalRdrEnv export_env toplev_envs - writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplevs, - ic_exports = exports, + writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods, + ic_exports = export_mods, 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 ] + gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod) + | (Just avails, mod) <- zip mb_name_sets mods ] -- return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres -nameSetToGlobalRdrEnv :: NameSet -> Module -> GlobalRdrEnv +nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv nameSetToGlobalRdrEnv names mod = mkGlobalRdrEnv [ GRE { gre_name = name, gre_prov = vanillaProv mod } | name <- nameSetToList names ] -vanillaProv :: Module -> Provenance +vanillaProv :: ModuleName -> 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}] +vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}] where - decl = ImpDeclSpec { is_mod = mod, is_as = mod, + decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, is_qual = False, is_dloc = srcLocSpan interactiveSrcLoc } -checkModuleExists :: HscEnv -> HomePackageTable -> Module -> IO () -checkModuleExists hsc_env hpt mod = - case lookupModuleEnv hpt mod of - Just mod_info -> return () - _not_a_home_module -> do - res <- findPackageModule hsc_env mod True - case res of - Found _ _ -> return () - err -> let msg = cantFindError (hsc_dflags hsc_env) mod err in - throwDyn (CmdLineError (showSDoc msg)) - mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv mkTopLevEnv hpt modl - = case lookupModuleEnv hpt modl of - Nothing -> - throwDyn (ProgramError ("mkTopLevEnv: not a home module " - ++ showSDoc (pprModule modl))) + = case lookupUFM hpt (moduleName modl) of + Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++ + showSDoc (ppr modl))) Just details -> case mi_globals (hm_iface details) of Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not interpreted " - ++ showSDoc (pprModule modl))) + ++ showSDoc (ppr modl))) Just env -> return env -- | Get the interactive evaluation context, consisting of a pair of the @@ -1896,9 +2014,11 @@ getContext s = withSession s (\HscEnv{ hsc_IC=ic } -> -- its full top-level scope available. moduleIsInterpreted :: Session -> Module -> IO Bool moduleIsInterpreted s modl = withSession s $ \h -> - case lookupModuleEnv (hsc_HPT h) modl of - Just details -> return (isJust (mi_globals (hm_iface details))) - _not_a_home_module -> return False + if modulePackageId modl /= thisPackage (hsc_dflags h) + then return False + else case lookupUFM (hsc_HPT h) (moduleName modl) of + Just details -> return (isJust (mi_globals (hm_iface details))) + _not_a_home_module -> return False -- | Looks up an identifier in the current interactive context (for :info) getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance])) @@ -1988,20 +2108,51 @@ compileExpr s expr = withSession s $ \hsc_env -> do _ -> panic "compileExpr" -- ----------------------------------------------------------------------------- +-- Compile an expression into a dynamic + +dynCompileExpr :: Session -> String -> IO (Maybe Dynamic) +dynCompileExpr ses expr = do + (full,exports) <- getContext ses + setContext ses full $ + (mkModule + (stringToPackageId "base") (mkModuleName "Data.Dynamic") + ):exports + let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")" + res <- withSession ses (flip hscStmt stmt) + setContext ses full exports + case res of + Nothing -> return Nothing + Just (_, names, hvals) -> do + vals <- (unsafeCoerce# hvals :: IO [Dynamic]) + case (names,vals) of + (_:[], v:[]) -> return (Just v) + _ -> panic "dynCompileExpr" + +-- ----------------------------------------------------------------------------- -- running a statement interactively data RunResult = RunOk [Name] -- ^ names bound by this evaluation | RunFailed -- ^ statement failed compilation | RunException Exception -- ^ statement raised an exception + | RunBreak ThreadId [Name] BreakInfo ResumeHandle + +data Status + = Break HValue BreakInfo ThreadId ResumeHandle -- ^ the computation hit a breakpoint + | Complete (Either Exception [HValue]) -- ^ the computation completed with either an exception or a value --- | Run a statement in the current interactive context. Statemenet +data ResumeHandle = ResumeHandle (MVar ()) (MVar Status) [Name] + +-- | Run a statement in the current interactive context. Statement -- may bind multple values. runStmt :: Session -> String -> IO RunResult runStmt (Session ref) expr = do hsc_env <- readIORef ref + breakMVar <- newEmptyMVar -- wait on this when we hit a breakpoint + statusMVar <- newEmptyMVar -- wait on this when a computation is running + -- Turn off -fwarn-unused-bindings when running a statement, to hide -- warnings about the implicit bindings we introduce. let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds @@ -2012,37 +2163,66 @@ runStmt (Session ref) expr case maybe_stuff of Nothing -> return RunFailed Just (new_hsc_env, names, hval) -> do - - let thing_to_run = unsafeCoerce# hval :: IO [HValue] - either_hvals <- sandboxIO thing_to_run - + writeIORef ref new_hsc_env + + let resume_handle = ResumeHandle breakMVar statusMVar names + -- set the onBreakAction to be performed when we hit a + -- breakpoint this is visible in the Byte Code + -- Interpreter, thus it is a global variable, + -- implemented with stable pointers + stablePtr <- setBreakAction resume_handle + + let thing_to_run = unsafeCoerce# hval :: IO [HValue] + status <- sandboxIO statusMVar thing_to_run + freeStablePtr stablePtr -- be careful not to leak stable pointers! + handleRunStatus ref names status + +handleRunStatus ref names status = + case status of + -- did we hit a breakpoint or did we complete? + (Break apStack info tid res) -> do + hsc_env <- readIORef ref + (new_hsc_env, names) <- extendEnvironment hsc_env apStack + (breakInfo_vars info) + writeIORef ref new_hsc_env + return (RunBreak tid names info res) + (Complete either_hvals) -> case either_hvals of - Left e -> do - -- on error, keep the *old* interactive context, - -- so that 'it' is not bound to something - -- that doesn't exist. - return (RunException e) - + Left e -> return (RunException e) Right hvals -> do - -- Get the newly bound things, and bind them. - -- Don't need to delete any shadowed bindings; - -- the new ones override the old ones. extendLinkEnv (zip names hvals) - - writeIORef ref new_hsc_env return (RunOk names) + +-- this points to the IO action that is executed when a breakpoint is hit +foreign import ccall "&breakPointIOAction" + breakPointIOAction :: Ptr (StablePtr (BreakInfo -> HValue -> IO ())) -- 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 = do - m <- newEmptyMVar +sandboxIO :: MVar Status -> IO [HValue] -> IO Status +sandboxIO statusMVar thing = do ts <- takeMVar interruptTargetThread - child <- forkIO (do res <- Exception.try thing; putMVar m res) + child <- forkIO (do res <- Exception.try thing; putMVar statusMVar (Complete res)) putMVar interruptTargetThread (child:ts) - takeMVar m `finally` modifyMVar_ interruptTargetThread (return.tail) + takeMVar statusMVar `finally` modifyMVar_ interruptTargetThread (return.tail) + +setBreakAction res@(ResumeHandle breakMVar statusMVar names) = do + stablePtr <- newStablePtr onBreak + poke breakPointIOAction stablePtr + return stablePtr + where onBreak ids apStack = do + tid <- myThreadId + putMVar statusMVar (Break apStack ids tid res) + takeMVar breakMVar + +resume :: Session -> ResumeHandle -> IO RunResult +resume (Session ref) res@(ResumeHandle breakMVar statusMVar names) = do + stablePtr <- setBreakAction res + putMVar breakMVar () + status <- takeMVar statusMVar + handleRunStatus ref names status {- -- This version of sandboxIO runs the expression in a completely new @@ -2069,17 +2249,87 @@ sandboxIO thing = do foreign import "rts_evalStableIO" {- safe -} rts_evalStableIO :: StablePtr (IO a) -> Ptr (StablePtr a) -> IO CInt -- more informative than the C type! + +XXX the type of rts_evalStableIO no longer matches the above + -} +-- ----------------------------------------------------------------------------- +-- After stopping at a breakpoint, add free variables to the environment + +-- Todo: turn this into a primop, and provide special version(s) for unboxed things +foreign import ccall "rts_getApStackVal" getApStackVal :: StablePtr a -> Int -> IO (StablePtr b) + +getIdValFromApStack :: a -> (Id, Int) -> IO (Id, HValue) +getIdValFromApStack apStack (identifier, stackDepth) = do + -- ToDo: check the type of the identifer and decide whether it is unboxed or not + apSptr <- newStablePtr apStack + resultSptr <- getApStackVal apSptr (stackDepth - 1) + result <- deRefStablePtr resultSptr + freeStablePtr apSptr + freeStablePtr resultSptr + return (identifier, unsafeCoerce# result) + +extendEnvironment :: HscEnv -> a -> [(Id, Int)] -> IO (HscEnv, [Name]) +extendEnvironment hsc_env apStack idsOffsets = do + idsVals <- mapM (getIdValFromApStack apStack) idsOffsets + let (ids, hValues) = unzip idsVals + let names = map idName ids + let global_ids = map globaliseAndTidy ids + typed_ids <- mapM instantiateIdType global_ids + let ictxt = hsc_IC hsc_env + rn_env = ic_rn_local_env ictxt + type_env = ic_type_env ictxt + bound_names = map idName typed_ids + new_rn_env = extendLocalRdrEnv rn_env bound_names + -- Remove any shadowed bindings from the type_env; + -- they are inaccessible but might, I suppose, cause + -- a space leak if we leave them there + shadowed = [ n | name <- bound_names, + let rdr_name = mkRdrUnqual (nameOccName name), + Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] + filtered_type_env = delListFromNameEnv type_env shadowed + new_type_env = extendTypeEnvWithIds filtered_type_env (typed_ids) + new_ic = ictxt { ic_rn_local_env = new_rn_env, + ic_type_env = new_type_env } + extendLinkEnv (zip names hValues) -- ToDo: we must remember to restore the old env after we finish a breakpoint + return (hsc_env{hsc_IC = new_ic}, names) + where + globaliseAndTidy :: Id -> Id + globaliseAndTidy id + = let tidied_type = tidyTopType$ idType id + in setIdType (globaliseId VanillaGlobal id) tidied_type + + -- | Instantiate the tyVars with GHC.Base.Unknown + instantiateIdType :: Id -> IO Id + instantiateIdType id = do + instantiatedType <- instantiateTyVarsToUnknown hsc_env (idType id) + return$ setIdType id instantiatedType + ----------------------------------------------------------------------------- -- show a module and it's source/object filenames showModule :: Session -> ModSummary -> IO String -showModule s mod_summary = withSession s $ \hsc_env -> do - case lookupModuleEnv (hsc_HPT hsc_env) (ms_mod mod_summary) of +showModule s mod_summary = withSession s $ \hsc_env -> + isModuleInterpreted s mod_summary >>= \interpreted -> + return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary) + +isModuleInterpreted :: Session -> ModSummary -> IO Bool +isModuleInterpreted s mod_summary = withSession s $ \hsc_env -> + case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of Nothing -> panic "missing linkable" - Just mod_info -> return (showModMsg (hscTarget (hsc_dflags hsc_env)) (not obj_linkable) mod_summary) + Just mod_info -> return (not obj_linkable) where obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info)) +obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term +obtainTerm1 sess force mb_ty x = withSession sess $ \hsc_env -> cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x) + +obtainTerm :: Session -> Bool -> Id -> IO (Maybe Term) +obtainTerm sess force id = withSession sess $ \hsc_env -> do + mb_v <- getHValue (varName id) + case mb_v of + Just v -> fmap Just$ cvObtainTerm hsc_env force (Just$ idType id) v + Nothing -> return Nothing + #endif /* GHCI */