X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=c4bdf9602b9becaac9ed4f719a0367a37de6290d;hb=03b53752e99e09edea7d20533019e0ed885e3a23;hp=b023885f2e2d98bb563a7ffdf58d4c26a92ed674;hpb=67ad7f3ba7381ec815faf55be1ca6a4c6a919cb1;p=ghc-hetmet.git diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index b023885..c4bdf96 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -17,7 +17,7 @@ module GHC ( gcatch, gbracket, gfinally, clearWarnings, getWarnings, hasWarnings, printExceptionAndWarnings, printWarnings, - handleSourceError, + handleSourceError, defaultCallbacks, GhcApiCallbacks(..), -- * Flags and settings DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt, @@ -43,16 +43,19 @@ module GHC ( -- * Loading\/compiling the program depanal, - load, loadWithLogger, LoadHowMuch(..), SuccessFlag(..), -- also does depanal + load, loadWithLogger, LoadHowMuch(..), + SuccessFlag(..), succeeded, failed, defaultWarnErrLogger, WarnErrLogger, workingDirectoryChanged, parseModule, typecheckModule, desugarModule, loadModule, ParsedModule, TypecheckedModule, DesugaredModule, -- all abstract TypecheckedSource, ParsedSource, RenamedSource, -- ditto + TypecheckedMod, ParsedMod, moduleInfo, renamedSource, typecheckedSource, parsedSource, coreModule, compileToCoreModule, compileToCoreSimplified, compileCoreToObj, + getModSummary, -- * Parsing Haddock comments parseHaddockComment, @@ -73,8 +76,12 @@ module GHC ( modInfoIsExportedName, modInfoLookupName, lookupGlobalName, + findGlobalAnns, mkPrintUnqualifiedForModule, + -- * Querying the environment + packageDbModules, + -- * Printing PrintUnqualified, alwaysQualify, @@ -195,6 +202,20 @@ module GHC ( srcSpanStartLine, srcSpanEndLine, srcSpanStartCol, srcSpanEndCol, + -- ** Located + Located(..), + + -- *** Constructing Located + noLoc, mkGeneralLocated, + + -- *** Deconstructing Located + getLoc, unLoc, + + -- *** Combining and comparing Located values + eqLocated, cmpLocated, combineLocs, addCLoc, + leftmost_smallest, leftmost_largest, rightmost, + spans, isSubspanOf, + -- * Exceptions GhcException(..), showGhcException, @@ -263,8 +284,10 @@ import StaticFlagParser import qualified StaticFlags import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept, cleanTempDirs ) +import Annotations import Module import LazyUniqFM +import qualified UniqFM as UFM import UniqSet import Unique import FiniteMap @@ -289,6 +312,8 @@ import System.Directory ( getModificationTime, doesFileExist, import Data.Maybe import Data.List import qualified Data.List as List +import Data.Typeable ( Typeable ) +import Data.Word ( Word8 ) import Control.Monad import System.Exit ( exitWith, ExitCode(..) ) import System.Time ( ClockTime, getClockTime ) @@ -297,9 +322,6 @@ import Data.IORef import System.FilePath import System.IO import System.IO.Error ( try, isDoesNotExistError ) -#if __GLASGOW_HASKELL__ >= 609 -import Data.Typeable (cast) -#endif import Prelude hiding (init) @@ -313,45 +335,22 @@ import Prelude hiding (init) defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => DynFlags -> m a -> m a defaultErrorHandler dflags inner = -- top-level exception handler: any unrecognised exception is a compiler bug. -#if __GLASGOW_HASKELL__ < 609 ghandle (\exception -> liftIO $ do hFlush stdout - case exception of - -- an IO exception probably isn't our fault, so don't panic - IOException _ -> - fatalErrorMsg dflags (text (show exception)) - AsyncException StackOverflow -> - fatalErrorMsg dflags (text "stack overflow: use +RTS -K to increase it") - ExitException _ -> throw exception - _ -> - fatalErrorMsg dflags (text (show (Panic (show exception)))) - exitWith (ExitFailure 1) - ) $ -#else - ghandle (\(SomeException exception) -> liftIO $ do - hFlush stdout - case cast exception of + case fromException exception of -- an IO exception probably isn't our fault, so don't panic Just (ioe :: IOException) -> fatalErrorMsg dflags (text (show ioe)) - _ -> case cast exception of + _ -> case fromException exception of Just StackOverflow -> fatalErrorMsg dflags (text "stack overflow: use +RTS -K to increase it") - _ -> case cast exception of + _ -> case fromException exception of Just (ex :: ExitCode) -> throw ex _ -> fatalErrorMsg dflags (text (show (Panic (show exception)))) exitWith (ExitFailure 1) ) $ -#endif - - -- program errors: messages with locations attached. Sometimes it is - -- convenient to just throw these as exceptions. - handleErrMsg - (\em -> liftIO $ do - printBagOfErrors dflags (unitBag em) - exitWith (ExitFailure 1)) $ -- error messages propagated as exceptions handleGhcException @@ -469,10 +468,17 @@ initGhcMonad mb_top_dir = do dflags0 <- liftIO $ initDynFlags defaultDynFlags dflags <- liftIO $ initSysTools mb_top_dir dflags0 - env <- liftIO $ newHscEnv dflags + env <- liftIO $ newHscEnv defaultCallbacks dflags setSession env clearWarnings +defaultCallbacks :: GhcApiCallbacks +defaultCallbacks = + GhcApiCallbacks { + reportModuleCompilationResult = + \_ mb_err -> defaultWarnErrLogger mb_err + } + -- ----------------------------------------------------------------------------- -- Flags & settings @@ -661,9 +667,14 @@ data LoadHowMuch -- | Try to load the program. Calls 'loadWithLogger' with the default -- compiler that just immediately logs all warnings and errors. +-- +-- This function may throw a 'SourceError' if errors are encountered before +-- the actual compilation starts (e.g., during dependency analysis). +-- load :: GhcMonad m => LoadHowMuch -> m SuccessFlag -load how_much = - loadWithLogger defaultWarnErrLogger how_much +load how_much = do + mod_graph <- depanal [] False + load2 how_much mod_graph -- | A function called to log warnings and errors. type WarnErrLogger = GhcMonad m => Maybe SourceError -> m () @@ -678,19 +689,24 @@ defaultWarnErrLogger (Just e) = printExceptionAndWarnings e -- -- The first argument is a function that is called after compiling each -- module to print wanrings and errors. - +-- +-- While compiling a module, all 'SourceError's are caught and passed to the +-- logger, however, this function may still throw a 'SourceError' if +-- dependency analysis failed (e.g., due to a parse error). +-- loadWithLogger :: GhcMonad m => WarnErrLogger -> LoadHowMuch -> m SuccessFlag loadWithLogger logger 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 -- graph is still retained in the Session. We can tell which modules -- were successfully loaded by inspecting the Session's HPT. - mod_graph <- depanal [] False - load2 how_much mod_graph logger + withLocalCallbacks (\cbs -> cbs { reportModuleCompilationResult = + \_ -> logger }) $ + load how_much -load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] -> WarnErrLogger +load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] -> m SuccessFlag -load2 how_much mod_graph logger = do +load2 how_much mod_graph = do guessOutputFile hsc_env <- getSession @@ -732,7 +748,7 @@ load2 how_much mod_graph logger = do -- If we can determine that any of the {-# SOURCE #-} imports -- are definitely unnecessary, then emit a warning. - warnUnnecessarySourceImports dflags mg2_with_srcimps + warnUnnecessarySourceImports mg2_with_srcimps let -- check the stability property for each module. @@ -817,8 +833,7 @@ load2 how_much mod_graph logger = do liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") 2 (ppr mg)) (upsweep_ok, hsc_env1, modsUpswept) - <- upsweep logger - (hsc_env { hsc_HPT = emptyHomePackageTable }) + <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable }) pruned_hpt stable_mods cleanup mg -- Make modsDone be the summaries for each home module now @@ -1013,22 +1028,30 @@ type TypecheckedSource = LHsBinds Id -- - default methods are turned into top-level decls. -- - dictionary bindings +-- | Return the 'ModSummary' of a module with the given name. +-- +-- The module must be part of the module graph (see 'hsc_mod_graph' and +-- 'ModuleGraph'). If this is not the case, this function will throw a +-- 'GhcApiError'. +-- +-- This function ignores boot modules and requires that there is only one +-- non-boot module with the given name. getModSummary :: GhcMonad m => ModuleName -> m ModSummary getModSummary mod = do mg <- liftM hsc_mod_graph getSession - case [ ms | ms <- mg, ms_mod_name ms == mod ] of + case [ ms | ms <- mg, ms_mod_name ms == mod, not (isBootSummary ms) ] of [] -> throw $ mkApiErr (text "Module not part of module graph") - (ms:_) -> return ms + [ms] -> return ms + multiple -> throw $ mkApiErr (text "getModSummary is ambiguous: " <+> ppr multiple) -- | Parse a module. -- -- Throws a 'SourceError' on parse error. -parseModule :: GhcMonad m => ModuleName -> m ParsedModule -parseModule mod = do - ms <- getModSummary mod - hsc_env0 <- getSession - let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms } - rdr_module <- parseFile hsc_env ms +parseModule :: GhcMonad m => ModSummary -> m ParsedModule +parseModule ms = do + rdr_module <- withTempSession + (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ + hscParse ms return (ParsedModule ms rdr_module) -- | Typecheck and rename a parsed module. @@ -1036,12 +1059,11 @@ parseModule mod = do -- Throws a 'SourceError' if either fails. typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule typecheckModule pmod = do - let ms = modSummary pmod - hsc_env0 <- getSession - let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms } + let ms = modSummary pmod + withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do (tc_gbl_env, rn_info) - <- typecheckRenameModule hsc_env ms (parsedSource pmod) - details <- liftIO $ makeSimpleDetails hsc_env tc_gbl_env + <- hscTypecheckRename ms (parsedSource pmod) + details <- makeSimpleDetails tc_gbl_env return $ TypecheckedModule { tm_internals_ = (tc_gbl_env, details), @@ -1062,11 +1084,10 @@ typecheckModule pmod = do -- | Desugar a typechecked module. desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule desugarModule tcm = do - let ms = modSummary tcm - hsc_env0 <- getSession - let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms } + let ms = modSummary tcm + withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do let (tcg, _) = tm_internals tcm - guts <- deSugarModule hsc_env ms tcg + guts <- hscDesugar ms tcg return $ DesugaredModule { dm_typechecked_module = tcm, @@ -1080,16 +1101,23 @@ loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod loadModule tcm = do let ms = modSummary tcm let mod = ms_mod_name ms - hsc_env0 <- getSession - let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms } - let (tcg, details) = tm_internals tcm - (iface,_) <- liftIO $ 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 - modifySession $ \_ -> hsc_env0{ hsc_HPT = hpt_new } + let (tcg, _details) = tm_internals tcm + hpt_new <- + withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do + + let compilerBackend comp env ms' _ _mb_old_iface _ = + withTempSession (\_ -> env) $ + hscBackend comp tcg ms' + Nothing + hsc_env <- getSession + mod_info + <- compile' (compilerBackend hscNothingCompiler + ,compilerBackend hscInteractiveCompiler + ,compilerBackend hscBatchCompiler) + hsc_env ms 1 1 Nothing Nothing + -- compile' shouldn't change the environment + return $ addToUFM (hsc_HPT hsc_env) mod mod_info + modifySession $ \e -> e{ hsc_HPT = hpt_new } return tcm -- | This is the way to get access to the Core bindings corresponding @@ -1118,11 +1146,9 @@ compileToCore fn = do -- 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 :: GhcMonad m => Bool -> CoreModule -> m () compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do - hscEnv <- getSession dflags <- getSessionDynFlags currentTime <- liftIO $ getClockTime cwd <- liftIO $ getCurrentDirectory @@ -1147,15 +1173,13 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do ms_hspp_buf = Nothing } - ioMsgMaybe $ flip evalComp (CompState{ compHscEnv=hscEnv, - compModSummary=modSummary, - compOldIface=Nothing}) $ - let maybe_simplify mod_guts | simplify = hscSimplify mod_guts - | otherwise = return mod_guts - in maybe_simplify (mkModGuts cm) - >>= hscNormalIface - >>= hscWriteIface - >>= hscOneShot + let maybe_simplify mod_guts | simplify = hscSimplify mod_guts + | otherwise = return mod_guts + guts <- maybe_simplify (mkModGuts cm) + (iface, changed, _details, cgguts) + <- hscNormalIface guts Nothing + hscWriteIface iface changed modSummary + hscGenHardCode cgguts modSummary return () -- Makes a "vanilla" ModGuts. @@ -1176,6 +1200,7 @@ mkModGuts coreModule = ModGuts { mg_binds = cm_binds coreModule, mg_foreign = NoStubs, mg_warns = NoWarnings, + mg_anns = [], mg_hpc_info = emptyHpcInfo False, mg_modBreaks = emptyModBreaks, mg_vect_info = noVectInfo, @@ -1195,20 +1220,16 @@ compileCore simplify fn = do Just modSummary -> do -- Now we have the module name; -- parse, typecheck and desugar the module - let mod = ms_mod_name modSummary mod_guts <- coreModule `fmap` - (desugarModule =<< typecheckModule =<< parseModule mod) + -- TODO: space leaky: call hsc* directly? + (desugarModule =<< typecheckModule =<< parseModule modSummary) liftM gutsToCoreModule $ if simplify then do -- If simplify is true: simplify (hscSimplify), then tidy -- (tidyProgram). hsc_env <- getSession - simpl_guts <- ioMsg $ evalComp (hscSimplify mod_guts) - (CompState{ - compHscEnv = hsc_env, - compModSummary = modSummary, - compOldIface = Nothing}) + simpl_guts <- hscSimplify mod_guts tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts return $ Left tidy_guts else @@ -1313,7 +1334,7 @@ checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs 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)) + scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc)) -- all imports outside the current SCC, but in the home pkg stable_obj_imps = map (`elem` stable_obj) scc_allimps @@ -1350,9 +1371,6 @@ checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs linkableTime l >= ms_hs_date ms _other -> False -ms_allimps :: ModSummary -> [ModuleName] -ms_allimps ms = map unLoc (ms_srcimps ms ++ ms_imps ms) - -- ----------------------------------------------------------------------------- -- | Prune the HomePackageTable @@ -1425,8 +1443,7 @@ findPartiallyCompletedCycles modsDone theGraph upsweep :: GhcMonad m => - WarnErrLogger -- ^ Called to print warnings and errors. - -> HscEnv -- ^ Includes initially-empty HPT + HscEnv -- ^ Includes initially-empty HPT -> HomePackageTable -- ^ HPT from last time round (pruned) -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability) -> IO () -- ^ How to clean up unwanted tmp files @@ -1435,7 +1452,7 @@ upsweep HscEnv, -- With an updated HPT [ModSummary]) -- Mods which succeeded -upsweep logger hsc_env old_hpt stable_mods cleanup sccs = do +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 @@ -1454,13 +1471,14 @@ upsweep logger hsc_env old_hpt stable_mods cleanup sccs = do = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ -- show (map (moduleUserString.moduleName.mi_module.hm_iface) -- (moduleEnvElts (hsc_HPT hsc_env))) + let logger = reportModuleCompilationResult (hsc_callbacks hsc_env) mb_mod_info <- handleSourceError - (\err -> do logger (Just err); return Nothing) $ do + (\err -> do logger mod (Just err); return Nothing) $ do mod_info <- upsweep_mod hsc_env old_hpt stable_mods mod mod_index nmods - logger Nothing -- log warnings + logger mod Nothing -- log warnings return (Just mod_info) liftIO cleanup -- Remove unwanted tmp files between compilations @@ -1561,66 +1579,91 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods compile_it_discard_iface = compile hsc_env summary' mod_index nmods Nothing - in - case target of + -- With the HscNothing target we create empty linkables to avoid + -- recompilation. We have to detect these to recompile anyway if + -- the target changed since the last compile. + is_fake_linkable + | Just hmi <- old_hmi, Just l <- hm_linkable hmi = + null (linkableUnlinked l) + | otherwise = + -- we have no linkable, so it cannot be fake + False + + implies False _ = True + implies True x = x - _any + in + case () of + _ -- 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 -> - let Just hmi = old_hmi in - return hmi - -- object is stable, and we have an entry in the - -- old HPT: nothing to do - - | is_stable_obj, isNothing old_hmi -> do - linkable <- liftIO $ findObjectLinkable this_mod obj_fn - (expectJust "upsweep1" mb_obj_date) - compile_it (Just linkable) - -- object is stable, but we need to load the interface - -- off disk to make a HMI. - - HscInterpreted - | is_stable_bco -> - ASSERT(isJust old_hmi) -- must be in the old_hpt - let Just hmi = old_hmi in - return hmi - -- BCO is stable: nothing to do - - | Just hmi <- old_hmi, - Just l <- hm_linkable hmi, not (isObjectLinkable l), - linkableTime l >= ms_hs_date summary -> - compile_it (Just l) - -- we have an old BCO that is up to date with respect - -- to the source: do a recompilation check as normal. - - | otherwise -> - compile_it Nothing - -- no existing code at all: we must recompile. - - -- 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 <- liftIO $ findObjectLinkable this_mod obj_fn obj_date + | is_stable_obj, Just hmi <- old_hmi -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "skipping stable obj mod:" <+> ppr this_mod_name) + return hmi + -- object is stable, and we have an entry in the + -- old HPT: nothing to do + + | is_stable_obj, isNothing old_hmi -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling stable on-disk mod:" <+> ppr this_mod_name) + linkable <- liftIO $ findObjectLinkable this_mod obj_fn + (expectJust "upsweep1" mb_obj_date) + compile_it (Just linkable) + -- object is stable, but we need to load the interface + -- off disk to make a HMI. + + | not (isObjectTarget target), is_stable_bco, + (target /= HscNothing) `implies` not is_fake_linkable -> + ASSERT(isJust old_hmi) -- must be in the old_hpt + let Just hmi = old_hmi in do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "skipping stable BCO mod:" <+> ppr this_mod_name) + return hmi + -- BCO is stable: nothing to do + + | not (isObjectTarget target), + Just hmi <- old_hmi, + Just l <- hm_linkable hmi, + not (isObjectLinkable l), + (target /= HscNothing) `implies` not is_fake_linkable, + linkableTime l >= ms_hs_date summary -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling non-stable BCO mod:" <+> ppr this_mod_name) + 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. + + -- 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. + -- + | isObjectTarget target, + 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 -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name) + compile_it (Just l) + _otherwise -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name) + linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date compile_it_discard_iface (Just linkable) - _otherwise -> - compile_it Nothing + _otherwise -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod:" <+> ppr this_mod_name) + compile_it Nothing @@ -1707,11 +1750,12 @@ reachableBackwards mod summaries type SummaryNode = (ModSummary, Int, [Int]) topSortModuleGraph - :: Bool -- Drop hi-boot nodes? (see below) + :: Bool + -- ^ Drop hi-boot nodes? (see below) -> [ModSummary] -> Maybe ModuleName -> [SCC ModSummary] --- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes +-- ^ 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 @@ -1719,10 +1763,10 @@ topSortModuleGraph -- -- Drop hi-boot nodes (first boolean arg)? -- --- False: treat the hi-boot summaries as nodes of the graph, +-- - @False@: treat the hi-boot summaries as nodes of the graph, -- so the graph must be acyclic -- --- True: eliminate the hi-boot nodes, and instead pretend +-- - @True@: eliminate the hi-boot nodes, and instead pretend -- the a source-import of Foo is an import of Foo -- The resulting graph has no hi-boot nodes, but can be cyclic @@ -1770,8 +1814,8 @@ moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, l | (s, key) <- numbered_summaries -- Drop the hi-boot ones if told to do so , not (isBootSummary s && drop_hs_boot_nodes) - , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++ - out_edge_keys HsSrcFile (map unLoc (ms_imps s)) ++ + , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++ + out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++ (-- see [boot-edges] below if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile then [] @@ -1813,13 +1857,13 @@ nodeMapElts = eltsFM -- 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 :: GhcMonad m => DynFlags -> [SCC ModSummary] -> m () -warnUnnecessarySourceImports dflags sccs = - liftIO $ printBagOfWarnings dflags (listToBag (concatMap (check.flattenSCC) sccs)) +warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m () +warnUnnecessarySourceImports sccs = + logWarnings (listToBag (concatMap (check.flattenSCC) sccs)) where check ms = let mods_in_this_cycle = map ms_mod_name ms in - [ warn i | m <- ms, i <- ms_srcimps m, - unLoc i `notElem` mods_in_this_cycle ] + [ warn i | m <- ms, i <- ms_home_srcimps m, + unLoc i `notElem` mods_in_this_cycle ] warn :: Located ModuleName -> WarnMsg warn (L loc mod) = @@ -1875,7 +1919,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots if exists then summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf - else throwErrMsg $ mkPlainErrMsg noSrcSpan $ + else throwOneError $ mkPlainErrMsg noSrcSpan $ text "can't find file:" <+> text file getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) = do maybe_summary <- summariseModule hsc_env old_summary_map False @@ -1941,8 +1985,20 @@ msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)] -- Remember, this pass isn't doing the topological sort. It's -- just gathering the list of all relevant ModSummaries msDeps s = - concat [ [(m,True), (m,False)] | m <- ms_srcimps s ] - ++ [ (m,False) | m <- ms_imps s ] + concat [ [(m,True), (m,False)] | m <- ms_home_srcimps s ] + ++ [ (m,False) | m <- ms_home_imps s ] + +home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName] +home_imps imps = [ ideclName i | L _ i <- imps, isNothing (ideclPkgQual i) ] + +ms_home_allimps :: ModSummary -> [ModuleName] +ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms) + +ms_home_srcimps :: ModSummary -> [Located ModuleName] +ms_home_srcimps = home_imps . ms_srcimps + +ms_home_imps :: ModSummary -> [Located ModuleName] +ms_home_imps = home_imps . ms_imps ----------------------------------------------------------------------------- -- Summarising modules @@ -2004,7 +2060,7 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf (dflags', hspp_fn, buf) <- preprocessFile hsc_env file mb_phase maybe_buf - (srcimps,the_imps, L _ mod_name) <- liftIO $ getImports dflags' buf hspp_fn file + (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file -- Make a ModLocation for this file location <- liftIO $ mkHomeModLocation dflags mod_name file @@ -2136,10 +2192,10 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) -- Preprocess the source file and get its imports -- The dflags' contains the OPTIONS pragmas (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf - (srcimps, the_imps, L mod_loc mod_name) <- liftIO $ getImports dflags' buf hspp_fn src_fn + (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn when (mod_name /= wanted_mod) $ - throwErrMsg $ mkPlainErrMsg mod_loc $ + throwOneError $ mkPlainErrMsg mod_loc $ text "File name does not match module name:" $$ text "Saw:" <+> quotes (ppr mod_name) $$ text "Expected:" <+> quotes (ppr wanted_mod) @@ -2190,8 +2246,8 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) -- (dflags', leftovers, warns) <- parseDynamicNoPackageFlags dflags local_opts - liftIO $ checkProcessArgsResult leftovers -- XXX: throws exceptions - liftIO $ handleFlagWarnings dflags' warns -- XXX: throws exceptions + checkProcessArgsResult leftovers + handleFlagWarnings dflags' warns let needs_preprocessing @@ -2215,21 +2271,21 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) 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 - = throwErrMsg $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err + = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err -noHsFileErr :: SrcSpan -> String -> a +noHsFileErr :: GhcMonad m => SrcSpan -> String -> m a noHsFileErr loc path - = throwErrMsg $ mkPlainErrMsg loc $ text "Can't find" <+> text path + = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path -packageModErr :: ModuleName -> a +packageModErr :: GhcMonad m => ModuleName -> m a packageModErr mod - = throwErrMsg $ mkPlainErrMsg noSrcSpan $ + = throwOneError $ mkPlainErrMsg noSrcSpan $ text "module" <+> quotes (ppr mod) <+> text "is a package module" multiRootsErr :: [ModSummary] -> IO () multiRootsErr [] = panic "multiRootsErr" multiRootsErr summs@(summ1:_) - = throwErrMsg $ mkPlainErrMsg noSrcSpan $ + = throwOneError $ mkPlainErrMsg noSrcSpan $ text "module" <+> quotes (ppr mod) <+> text "is defined in multiple files:" <+> sep (map text files) @@ -2411,9 +2467,12 @@ isDictonaryId id -- 'setContext'. lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing) lookupGlobalName name = withSession $ \hsc_env -> do - eps <- liftIO $ readIORef (hsc_EPS hsc_env) - return $! lookupType (hsc_dflags hsc_env) - (hsc_HPT hsc_env) (eps_PTE eps) name + liftIO $ lookupTypeHscEnv hsc_env name + +findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a] +findGlobalAnns deserialize target = withSession $ \hsc_env -> do + ann_env <- liftIO $ prepareAnnotations hsc_env Nothing + return (findAnns deserialize ann_env target) #ifdef GHCI -- | get the GlobalRdrEnv for a session @@ -2422,6 +2481,23 @@ getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env) #endif -- ----------------------------------------------------------------------------- + +-- | Return all /external/ modules available in the package database. +-- Modules from the current session (i.e., from the 'HomePackageTable') are +-- not included. +packageDbModules :: GhcMonad m => + Bool -- ^ Only consider exposed packages. + -> m [Module] +packageDbModules only_exposed = do + dflags <- getSessionDynFlags + let pkgs = UFM.eltsUFM (pkgIdMap (pkgState dflags)) + return $ + [ mkModule pid modname | p <- pkgs + , not only_exposed || exposed p + , pid <- [mkPackageId (package p)] + , modname <- exposedModules p ] + +-- ----------------------------------------------------------------------------- -- Misc exported utils dataConType :: DataCon -> Type