X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=c4bdf9602b9becaac9ed4f719a0367a37de6290d;hb=03b53752e99e09edea7d20533019e0ed885e3a23;hp=08ae6640530a651b2d52167af9edb19ac3e94be5;hpb=611deea9a835d9c0d6d991af78739732a26aa21a;p=ghc-hetmet.git diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 08ae664..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,7 +43,8 @@ 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, @@ -467,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 @@ -664,8 +672,9 @@ data LoadHowMuch -- 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 () @@ -691,12 +700,13 @@ loadWithLogger logger how_much = do -- 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 @@ -823,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 @@ -1092,15 +1101,21 @@ loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod loadModule tcm = do let ms = modSummary tcm let mod = ms_mod_name ms - let (tcg, details) = tm_internals tcm + let (tcg, _details) = tm_internals tcm hpt_new <- withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do - (iface, _) <- makeSimpleIface Nothing tcg details - let mod_info = HomeModInfo { - hm_iface = iface, - hm_details = details, - hm_linkable = Nothing } + + 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 @@ -1319,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 @@ -1356,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 @@ -1431,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 @@ -1441,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 @@ -1460,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 @@ -1802,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 [] @@ -1850,8 +1862,8 @@ 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) = @@ -1973,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