X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FGHC.hs;h=6ce921de3f27e98c8a59ab7c5975da80217d79c5;hb=e7da484086a7be73dbd0747b945fe63e7cd53ed0;hp=89b600b3defaa36962970f08a59be2dca67a299d;hpb=426e0396a790f7f65bdac142ab93761c46728045;p=ghc-hetmet.git diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs index 89b600b..6ce921d 100644 --- a/ghc/compiler/main/GHC.hs +++ b/ghc/compiler/main/GHC.hs @@ -17,6 +17,7 @@ module GHC ( -- * Flags and settings DynFlags(..), DynFlag(..), GhcMode(..), HscTarget(..), dopt, parseDynamicFlags, + initPackages, getSessionDynFlags, setSessionDynFlags, setMsgHandler, @@ -32,8 +33,10 @@ module GHC ( -- * Loading\/compiling the program depanal, load, LoadHowMuch(..), SuccessFlag(..), -- also does depanal + loadMsgs, workingDirectoryChanged, checkModule, CheckedModule(..), + TypecheckedSource, ParsedSource, -- * Inspecting the module structure of the program ModuleGraph, ModSummary(..), @@ -41,15 +44,25 @@ module GHC ( isLoaded, topSortModuleGraph, + -- * Inspecting modules + ModuleInfo, + getModuleInfo, + modInfoTyThings, + modInfoTopLevelScope, + modInfoPrintUnqualified, + modInfoExports, + lookupName, + -- * Interactive evaluation getBindings, getPrintUnqual, #ifdef GHCI setContext, getContext, + getNamesInScope, moduleIsInterpreted, getInfo, GetInfoResult, exprType, typeKind, - lookupName, + parseName, RunResult(..), runStmt, browseModule, @@ -58,14 +71,44 @@ module GHC ( #endif -- * Abstract syntax elements + + -- ** Modules Module, mkModule, pprModule, + + -- ** Names + Name, + + -- ** Identifiers + Id, idType, + isImplicitId, isDeadBinder, + isSpecPragmaId, isExportedId, isLocalId, isGlobalId, + isRecordSelector, + isPrimOpId, isFCallId, + isDataConWorkId, idDataCon, + isBottomingId, isDictonaryId, + + -- ** Type constructors + TyCon, + isClassTyCon, isSynTyCon, isNewTyCon, + + -- ** Data constructors + DataCon, + + -- ** Classes + Class, + classSCTheta, classTvsFds, + + -- ** Types and Kinds Type, dropForAlls, Kind, - Name, Id, TyCon, Class, DataCon, + + -- ** Entities TyThing(..), - idType, - -- used by DriverMkDepend: + -- * Exceptions + GhcException(..), showGhcException, + + -- * Miscellaneous sessionHscEnv, cyclicModuleErr, ) where @@ -88,9 +131,9 @@ module GHC ( import qualified Linker import Linker ( HValue, extendLinkEnv ) import NameEnv ( lookupNameEnv ) -import TcRnDriver ( mkExportEnv, getModuleContents ) -import RdrName ( GlobalRdrEnv, plusGlobalRdrEnv ) -import HscMain ( hscGetInfo, GetInfoResult, +import TcRnDriver ( mkExportEnv, getModuleContents, tcRnLookupRdrName ) +import RdrName ( plusGlobalRdrEnv ) +import HscMain ( hscGetInfo, GetInfoResult, hscParseIdentifier, hscStmt, hscTcExpr, hscKcType ) import Type ( tidyType ) import VarEnv ( emptyTidyEnv ) @@ -98,16 +141,24 @@ import GHC.Exts ( unsafeCoerce# ) import IfaceSyn ( IfaceDecl ) #endif +import Packages ( initPackages ) +import NameSet ( NameSet, nameSetToList ) +import RdrName ( GlobalRdrEnv ) import HsSyn ( HsModule, LHsBinds ) import Type ( Kind, Type, dropForAlls ) -import Id ( Id, idType ) -import TyCon ( TyCon ) -import Class ( Class ) +import Id ( Id, idType, isImplicitId, isDeadBinder, + isSpecPragmaId, isExportedId, isLocalId, isGlobalId, + isRecordSelector, + isPrimOpId, isFCallId, + isDataConWorkId, idDataCon, + isBottomingId ) +import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon ) +import Class ( Class, classSCTheta, classTvsFds ) import DataCon ( DataCon ) -import Name ( Name ) -import RdrName ( RdrName ) +import Name ( Name, getName, nameModule_maybe ) +import RdrName ( RdrName, gre_name, globalRdrEnvElts ) import NameEnv ( nameEnvElts ) -import SrcLoc ( Located ) +import SrcLoc ( Located(..), mkSrcLoc, srcLocSpan ) import DriverPipeline import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase ) import GetImports ( getImports ) @@ -122,7 +173,7 @@ import Module import FiniteMap import Panic import Digraph -import ErrUtils ( showPass, Messages, putMsg ) +import ErrUtils ( showPass, Messages, putMsg, debugTraceMsg ) import qualified ErrUtils import Util import StringBuffer ( StringBuffer, hGetStringBuffer ) @@ -130,9 +181,12 @@ import Outputable import SysTools ( cleanTempFilesExcept ) import BasicTypes ( SuccessFlag(..), succeeded, failed ) import Maybes ( orElse, expectJust, mapCatMaybes ) +import TcType ( tcSplitSigmaTy, isDictTy ) +import Bag ( unitBag, emptyBag ) +import FastString ( mkFastString ) import Directory ( getModificationTime, doesFileExist ) -import Maybe ( isJust, isNothing, fromJust ) +import Maybe ( isJust, isNothing, fromJust, fromMaybe, catMaybes ) import Maybes ( expectJust ) import List ( partition, nub ) import qualified List @@ -158,10 +212,10 @@ defaultErrorHandler inner = hFlush stdout case exception of -- an IO exception probably isn't our fault, so don't panic - IOException _ -> hPutStrLn stderr (show exception) + IOException _ -> putMsg (show exception) AsyncException StackOverflow -> - hPutStrLn stderr "stack overflow: use +RTS -K to increase it" - _other -> hPutStr stderr (show (Panic (show exception))) + putMsg "stack overflow: use +RTS -K to increase it" + _other -> putMsg (show (Panic (show exception))) exitWith (ExitFailure 1) ) $ @@ -171,7 +225,7 @@ defaultErrorHandler inner = case dyn of PhaseFailed _ code -> exitWith code Interrupted -> exitWith (ExitFailure 1) - _ -> do hPutStrLn stderr (show (dyn :: GhcException)) + _ -> do putMsg (show (dyn :: GhcException)) exitWith (ExitFailure 1) ) $ inner @@ -320,8 +374,8 @@ depanal (Session ref) excluded_mods = do old_graph = hsc_mod_graph hsc_env showPass dflags "Chasing dependencies" - when (verbosity dflags >= 1 && gmode == BatchCompile) $ - hPutStrLn stderr (showSDoc (hcat [ + when (gmode == BatchCompile) $ + debugTraceMsg dflags 1 (showSDoc (hcat [ text "Chasing modules from: ", hcat (punctuate comma (map pprTarget targets))])) @@ -353,7 +407,13 @@ 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 session how_much = + loadMsgs session how_much ErrUtils.printErrorsAndWarnings + +-- | Version of 'load' that takes a callback function to be invoked +-- on compiler errors and warnings as they occur during compilation. +loadMsgs :: Session -> LoadHowMuch -> (Messages-> IO ()) -> IO SuccessFlag +loadMsgs s@(Session ref) how_much msg_act = do -- Dependency analysis first. Note that this fixes the module graph: -- even if we don't get a fully successful upsweep, the full module @@ -400,8 +460,7 @@ load s@(Session ref) how_much evaluate pruned_hpt - when (verb >= 2) $ - putStrLn (showSDoc (text "Stable obj:" <+> ppr stable_obj $$ + debugTraceMsg dflags 2 (showSDoc (text "Stable obj:" <+> ppr stable_obj $$ text "Stable BCO:" <+> ppr stable_bco)) -- Unload any modules which are going to be re-linked this time around. @@ -448,7 +507,7 @@ load s@(Session ref) how_much List.init partial_mg0 | otherwise = partial_mg0 - + stable_mg = [ AcyclicSCC ms | AcyclicSCC ms <- full_mg, @@ -464,7 +523,7 @@ load s@(Session ref) how_much (upsweep_ok, hsc_env1, modsUpswept) <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable }) - pruned_hpt stable_mods cleanup mg + pruned_hpt stable_mods cleanup msg_act mg -- Make modsDone be the summaries for each home module now -- available; this should equal the domain of hpt3. @@ -479,7 +538,7 @@ load s@(Session ref) how_much then -- Easy; just relink it all. - do when (verb >= 2) $ putMsg "Upsweep completely successful." + do debugTraceMsg dflags 2 "Upsweep completely successful." -- Clean up after ourselves cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone) @@ -500,9 +559,8 @@ load s@(Session ref) how_much mod_graph do_linking = a_root_is_Main || no_hs_main - when (ghci_mode == BatchCompile && isJust ofile && not do_linking - && verb > 0) $ - putMsg ("Warning: output was redirected with -o, " ++ + when (ghci_mode == BatchCompile && isJust ofile && not do_linking) $ + debugTraceMsg dflags 1 ("Warning: output was redirected with -o, " ++ "but no output will be generated\n" ++ "because there is no " ++ main_mod ++ " module.") @@ -515,7 +573,7 @@ load s@(Session ref) how_much -- Tricky. We need to back out the effects of compiling any -- half-done cycles, both so as to clean up the top level envs -- and to avoid telling the interactive linker to link them. - do when (verb >= 2) $ putMsg "Upsweep partially successful." + do debugTraceMsg dflags 2 "Upsweep partially successful." let modsDone_names = map ms_mod modsDone @@ -574,11 +632,13 @@ ppFilesFromSummaries summaries = [ fn | Just fn <- map ms_hspp_file summaries ] data CheckedModule = CheckedModule { parsedSource :: ParsedSource, - typecheckedSource :: Maybe TypecheckedSource + -- ToDo: renamedSource + typecheckedSource :: Maybe TypecheckedSource, + checkedModuleInfo :: Maybe ModuleInfo } type ParsedSource = Located (HsModule RdrName) -type TypecheckedSource = (LHsBinds Id, GlobalRdrEnv) +type TypecheckedSource = LHsBinds Id -- | This is the way to get access to parsed and typechecked source code -- for a module. 'checkModule' loads all the dependencies of the specified @@ -588,7 +648,7 @@ checkModule :: Session -> Module -> (Messages -> IO ()) -> IO (Maybe CheckedModule) checkModule session@(Session ref) mod msg_act = do -- load up the dependencies first - r <- load session (LoadDependenciesOf mod) + r <- loadMsgs session (LoadDependenciesOf mod) msg_act if (failed r) then return Nothing else do -- now parse & typecheck the module @@ -597,14 +657,37 @@ checkModule session@(Session ref) mod msg_act = do case [ ms | ms <- mg, ms_mod ms == mod ] of [] -> return Nothing (ms:_) -> do - r <- hscFileCheck hsc_env msg_act ms + -- Add in the OPTIONS from the source file This is nasty: + -- we've done this once already, in the compilation manager + -- It might be better to cache the flags in the + -- ml_hspp_file field, say + let dflags0 = hsc_dflags hsc_env + hspp_buf = expectJust "GHC.checkModule" (ms_hspp_buf ms) + opts = getOptionsFromStringBuffer hspp_buf + (dflags1,leftovers) <- parseDynamicFlags dflags0 (map snd opts) + if (not (null leftovers)) + then do let filename = fromJust (ml_hs_file (ms_location ms)) + msg_act (optionsErrorMsgs leftovers opts filename) + return Nothing + else do + + r <- hscFileCheck hsc_env{hsc_dflags=dflags1} msg_act ms case r of HscFail -> return Nothing - HscChecked parsed tcd -> - return (Just (CheckedModule parsed tcd) ) + HscChecked parsed Nothing -> + return (Just (CheckedModule parsed Nothing Nothing)) + HscChecked parsed (Just (tc_binds, rdr_env, details)) -> do + let minf = ModuleInfo { + minf_details = details, + minf_rdr_env = Just rdr_env + } + return (Just (CheckedModule { + parsedSource = parsed, + typecheckedSource = Just tc_binds, + checkedModuleInfo = Just minf })) ------------------------------------------------------------------------------ +-- --------------------------------------------------------------------------- -- Unloading unload :: HscEnv -> [Linkable] -> IO () @@ -802,27 +885,32 @@ upsweep -> HomePackageTable -- HPT from last time round (pruned) -> ([Module],[Module]) -- stable modules (see checkStability) -> IO () -- How to clean up unwanted tmp files + -> (Messages -> IO ()) -- Compiler error message callback -> [SCC ModSummary] -- Mods to do (the worklist) -> IO (SuccessFlag, HscEnv, -- With an updated HPT [ModSummary]) -- Mods which succeeded -upsweep hsc_env old_hpt stable_mods cleanup - [] +upsweep hsc_env old_hpt stable_mods cleanup msg_act mods + = upsweep' hsc_env old_hpt stable_mods cleanup msg_act mods 1 (length mods) + +upsweep' hsc_env old_hpt stable_mods cleanup msg_act + [] _ _ = return (Succeeded, hsc_env, []) -upsweep hsc_env old_hpt stable_mods cleanup - (CyclicSCC ms:_) - = do hPutStrLn stderr (showSDoc (cyclicModuleErr ms)) +upsweep' hsc_env old_hpt stable_mods cleanup msg_act + (CyclicSCC ms:_) _ _ + = do putMsg (showSDoc (cyclicModuleErr ms)) return (Failed, hsc_env, []) -upsweep hsc_env old_hpt stable_mods cleanup - (AcyclicSCC mod:mods) +upsweep' hsc_env old_hpt stable_mods cleanup msg_act + (AcyclicSCC mod:mods) mod_index nmods = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ -- show (map (moduleUserString.moduleName.mi_module.hm_iface) -- (moduleEnvElts (hsc_HPT hsc_env))) - mb_mod_info <- upsweep_mod hsc_env old_hpt stable_mods mod + mb_mod_info <- upsweep_mod hsc_env old_hpt stable_mods msg_act mod + mod_index nmods cleanup -- Remove unwanted tmp files between compilations @@ -846,7 +934,8 @@ upsweep hsc_env old_hpt stable_mods cleanup | otherwise = delModuleEnv old_hpt this_mod ; (restOK, hsc_env2, modOKs) - <- upsweep hsc_env1 old_hpt1 stable_mods cleanup mods + <- upsweep' hsc_env1 old_hpt1 stable_mods cleanup + msg_act mods (mod_index+1) nmods ; return (restOK, hsc_env2, mod:modOKs) } @@ -856,10 +945,13 @@ upsweep hsc_env old_hpt stable_mods cleanup upsweep_mod :: HscEnv -> HomePackageTable -> ([Module],[Module]) + -> (Messages -> IO ()) -> 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 +upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) msg_act summary mod_index nmods = do let this_mod = ms_mod summary @@ -868,7 +960,8 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary hs_date = ms_hs_date summary compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo) - compile_it = upsweep_compile hsc_env old_hpt this_mod summary + compile_it = upsweep_compile hsc_env old_hpt this_mod + msg_act summary mod_index nmods case ghcMode (hsc_dflags hsc_env) of BatchCompile -> @@ -921,7 +1014,9 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary old_hmi = lookupModuleEnv old_hpt this_mod -- Run hsc to compile a module -upsweep_compile hsc_env old_hpt this_mod summary mb_old_linkable = do +upsweep_compile hsc_env old_hpt this_mod msg_act 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 @@ -941,7 +1036,8 @@ upsweep_compile hsc_env old_hpt this_mod summary mb_old_linkable = do where iface = hm_iface hm_info - compresult <- compile hsc_env summary mb_old_linkable mb_old_iface + compresult <- compile hsc_env msg_act summary mb_old_linkable mb_old_iface + mod_index nmods case compresult of -- Compilation failed. Compile may still have updated the PCS, tho. @@ -974,6 +1070,10 @@ topSortModuleGraph -> Maybe Module -> [SCC ModSummary] -- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes +-- The resulting list of strongly-connected-components is in topologically +-- sorted order, starting with the module(s) at the bottom of the +-- dependency graph (ie compile them first) and ending with the ones at +-- the top. -- -- Drop hi-boot nodes (first boolean arg)? -- @@ -1317,7 +1417,7 @@ preprocessFile dflags src_fn (Just (buf, time)) let local_opts = getOptionsFromStringBuffer buf -- - (dflags', errs) <- parseDynamicFlags dflags local_opts + (dflags', errs) <- parseDynamicFlags dflags (map snd local_opts) let needs_preprocessing @@ -1330,7 +1430,7 @@ preprocessFile dflags src_fn (Just (buf, time)) when needs_preprocessing $ ghcError (ProgramError "buffer needs preprocesing; interactive check disabled") - return (dflags', "", buf) + return (dflags', src_fn, buf) ----------------------------------------------------------------------------- @@ -1401,22 +1501,79 @@ getBindings s = withSession s (return . nameEnvElts . ic_type_env . hsc_IC) getPrintUnqual :: Session -> IO PrintUnqualified getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC) +#ifdef GHCI +-- | Parses a string as an identifier, and returns the list of 'Name's that +-- the identifier can refer to in the current interactive context. +parseName :: Session -> String -> IO [Name] +parseName s str = withSession s $ \hsc_env -> do + maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str + case maybe_rdr_name of + Nothing -> return [] + Just (L _ rdr_name) -> do + mb_names <- tcRnLookupRdrName hsc_env rdr_name + case mb_names of + Nothing -> return [] + Just ns -> return ns + -- ToDo: should return error messages +#endif + +-- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any +-- entity known to GHC, including 'Name's defined using 'runStmt'. +lookupName :: Session -> Name -> IO (Maybe TyThing) +lookupName s name = withSession s $ \hsc_env -> do + case lookupTypeEnv (ic_type_env (hsc_IC hsc_env)) name of + Just tt -> return (Just tt) + Nothing -> do + eps <- readIORef (hsc_EPS hsc_env) + return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name + +-- | Container for information about a 'Module'. +data ModuleInfo = ModuleInfo { + minf_details :: ModDetails, + minf_rdr_env :: Maybe GlobalRdrEnv + } + -- ToDo: this should really contain the ModIface too + -- We don't want HomeModInfo here, because a ModuleInfo applies + -- to package modules too. + +-- | Request information about a loaded 'Module' +getModuleInfo :: Session -> Module -> IO (Maybe ModuleInfo) +getModuleInfo s mdl = withSession s $ \hsc_env -> do + case lookupModuleEnv (hsc_HPT hsc_env) mdl of + Nothing -> return Nothing + Just hmi -> + return (Just (ModuleInfo { + minf_details = hm_details hmi, + minf_rdr_env = mi_globals $! hm_iface hmi + })) + + -- ToDo: we should be able to call getModuleInfo on a package module, + -- even one that isn't loaded yet. + +-- | The list of top-level entities defined in a module +modInfoTyThings :: ModuleInfo -> [TyThing] +modInfoTyThings minf = typeEnvElts (md_types (minf_details minf)) + +modInfoTopLevelScope :: ModuleInfo -> Maybe [Name] +modInfoTopLevelScope minf + = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf) + +modInfoExports :: ModuleInfo -> [Name] +modInfoExports minf = nameSetToList $! (md_exports $! minf_details minf) + +modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified +modInfoPrintUnqualified minf = fmap unQualInScope (minf_rdr_env minf) + +isDictonaryId :: Id -> Bool +isDictonaryId id + = case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau } + #if 0 -getModuleInfo :: Session -> Module -> IO ModuleInfo data ObjectCode = ByteCode | BinaryCode FilePath -data ModuleInfo = ModuleInfo { - lm_modulename :: Module, - lm_summary :: ModSummary, - lm_interface :: ModIface, - lm_tc_code :: Maybe TypecheckedCode, - lm_rn_code :: Maybe RenamedCode, - lm_obj :: Maybe ObjectCode - } - type TypecheckedCode = HsTypecheckedGroup type RenamedCode = [HsGroup Name] @@ -1534,9 +1691,15 @@ moduleIsInterpreted s modl = withSession s $ \h -> _not_a_home_module -> return False -- | Looks up an identifier in the current interactive context (for :info) +{-# DEPRECATED getInfo "we should be using parseName/lookupName instead" #-} getInfo :: Session -> String -> IO [GetInfoResult] getInfo s id = withSession s $ \hsc_env -> hscGetInfo hsc_env id +-- | Returns all names in scope in the current interactive context +getNamesInScope :: Session -> IO [Name] +getNamesInScope s = withSession s $ \hsc_env -> do + return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env)))) + -- ----------------------------------------------------------------------------- -- Getting the type of an expression @@ -1563,14 +1726,6 @@ typeKind s str = withSession s $ \hsc_env -> do Just kind -> return (Just kind) ----------------------------------------------------------------------------- --- lookupName: returns the TyThing for a Name in the interactive context. --- ToDo: should look it up in the full environment - -lookupName :: Session -> Name -> IO (Maybe TyThing) -lookupName s name = withSession s $ \hsc_env -> do - return $! lookupNameEnv (ic_type_env (hsc_IC hsc_env)) name - ------------------------------------------------------------------------------ -- cmCompileExpr: compile an expression and deliver an HValue compileExpr :: Session -> String -> IO (Maybe HValue) @@ -1670,6 +1825,7 @@ foreign import "rts_evalStableIO" {- safe -} -- --------------------------------------------------------------------------- -- cmBrowseModule: get all the TyThings defined in a module +{-# DEPRECATED browseModule "we should be using getModuleInfo instead" #-} browseModule :: Session -> Module -> Bool -> IO [IfaceDecl] browseModule s modl exports_only = withSession s $ \hsc_env -> do mb_decls <- getModuleContents hsc_env modl exports_only