X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FGhcMake.hs;h=5df0e13e87d5e33c4eb35ac98cf3e818e8ff2d3a;hp=5387245257d2aa0453664b99f0387e19bace40bc;hb=735519b465ba75a5d254848fb7f100bdaea89aa9;hpb=0ce8f5e727dfb59857a0f6e34d7617796e76baac diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 5387245..5df0e13 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -250,8 +250,9 @@ load2 how_much mod_graph = do mg = stable_mg ++ partial_mg -- clean up between compilations - let cleanup = cleanTempFilesExcept dflags - (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps)) + let cleanup hsc_env = intermediateCleanTempFiles dflags + (flattenSCCs mg2_with_srcimps) + hsc_env liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") 2 (ppr mg)) @@ -276,9 +277,10 @@ load2 how_much mod_graph = do do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.") -- Clean up after ourselves - liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone) + hsc_env1 <- getSession + liftIO $ intermediateCleanTempFiles dflags modsDone hsc_env1 - -- Issue a warning for the confusing case where the user + -- Issue a warning for the confusing case where the user -- said '-o foo' but we're not going to do any linking. -- We attempt linking if either (a) one of the modules is -- called Main, or (b) the user said -no-hs-main, indicating @@ -300,7 +302,6 @@ load2 how_much mod_graph = do moduleNameString (moduleName main_mod) ++ " module.") -- link everything together - hsc_env1 <- getSession linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) loadFinish Succeeded linkresult @@ -325,7 +326,7 @@ load2 how_much mod_graph = do (hsc_HPT hsc_env1) -- Clean up after ourselves - liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep) + liftIO $ intermediateCleanTempFiles dflags mods_to_keep hsc_env1 -- there should be no Nothings where linkables should be, now ASSERT(all (isJust.hm_linkable) @@ -363,11 +364,21 @@ discardProg hsc_env hsc_IC = emptyInteractiveContext, hsc_HPT = emptyHomePackageTable } --- used to fish out the preprocess output files for the purposes of --- cleaning up. The preprocessed file *might* be the same as the --- source file, but that doesn't do any harm. -ppFilesFromSummaries :: [ModSummary] -> [FilePath] -ppFilesFromSummaries summaries = map ms_hspp_file summaries +intermediateCleanTempFiles :: DynFlags -> [ModSummary] -> HscEnv -> IO () +intermediateCleanTempFiles dflags summaries hsc_env + = cleanTempFilesExcept dflags except + where + except = + -- Save preprocessed files. The preprocessed file *might* be + -- the same as the source file, but that doesn't do any + -- harm. + map ms_hspp_file summaries ++ + -- Save object files for loaded modules. The point of this + -- is that we might have generated and compiled a stub C + -- file, and in the case of GHCi the object file will be a + -- temporary file which we must not remove because we need + -- to load/link it later. + hptObjs (hsc_HPT hsc_env) -- | If there is no -o option, guess the name of target executable -- by using top-level source file name as a base. @@ -591,7 +602,7 @@ upsweep :: GhcMonad m => HomePackageTable -- ^ HPT from last time round (pruned) -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability) - -> IO () -- ^ How to clean up unwanted tmp files + -> (HscEnv -> IO ()) -- ^ How to clean up unwanted tmp files -> [SCC ModSummary] -- ^ Mods to do (the worklist) -> m (SuccessFlag, [ModSummary]) @@ -624,6 +635,10 @@ upsweep old_hpt stable_mods cleanup sccs = do let logger _mod = defaultWarnErrLogger hsc_env <- getSession + + -- Remove unwanted tmp files between compilations + liftIO (cleanup hsc_env) + mb_mod_info <- handleSourceError (\err -> do logger mod (Just err); return Nothing) $ do @@ -632,8 +647,6 @@ upsweep old_hpt stable_mods cleanup sccs = do logger mod Nothing -- log warnings return (Just mod_info) - liftIO cleanup -- Remove unwanted tmp files between compilations - case mb_mod_info of Nothing -> return (Failed, done) Just mod_info -> do @@ -1392,17 +1405,14 @@ preprocessFile hsc_env src_fn mb_phase Nothing preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) = do let dflags = hsc_dflags hsc_env - -- case we bypass the preprocessing stage? - let - local_opts = getOptions dflags buf src_fn - -- + let local_opts = getOptions dflags buf src_fn + (dflags', leftovers, warns) <- parseDynamicNoPackageFlags dflags local_opts checkProcessArgsResult leftovers handleFlagWarnings dflags' warns - let - needs_preprocessing + let needs_preprocessing | Just (Unlit _) <- mb_phase = True | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True -- note: local_opts is only required if there's no Unlit phase @@ -1446,20 +1456,53 @@ multiRootsErr summs@(summ1:_) files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs cyclicModuleErr :: [ModSummary] -> SDoc +-- From a strongly connected component we find +-- a single cycle to report cyclicModuleErr ms - = hang (ptext (sLit "Module imports form a cycle for modules:")) - 2 (vcat (map show_one ms)) + = ASSERT( not (null ms) ) + hang (ptext (sLit "Module imports form a cycle:")) + 2 (show_path (shortest [] root_mod)) where - mods_in_cycle = map ms_mod_name ms - imp_modname = unLoc . ideclName . unLoc - just_in_cycle = filter ((`elem` mods_in_cycle) . imp_modname) - - show_one ms = - vcat [ show_mod (ms_hsc_src ms) (ms_mod_name ms) <+> - maybe empty (parens . text) (ml_hs_file (ms_location ms)), - nest 2 $ ptext (sLit "imports:") <+> vcat [ - pp_imps HsBootFile (just_in_cycle $ ms_srcimps ms), - pp_imps HsSrcFile (just_in_cycle $ ms_imps ms) ] - ] - show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src) - pp_imps src imps = fsep (map (show_mod src . unLoc . ideclName . unLoc) imps) + deps :: [(ModuleName, [ModuleName])] + deps = [ (moduleName (ms_mod m), get_deps m) | m <- ms ] + + get_deps :: ModSummary -> [ModuleName] + get_deps m = filter (\k -> Map.member k dep_env) (map unLoc (ms_home_imps m)) + + dep_env :: Map.Map ModuleName [ModuleName] + dep_env = Map.fromList deps + + -- Find the module with fewest imports among the SCC modules + -- This is just a heuristic to find some plausible root module + root_mod :: ModuleName + root_mod = fst (minWith (length . snd) deps) + + shortest :: [ModuleName] -> ModuleName -> [ModuleName] + -- (shortest [v1,v2,..,vn] m) assumes that + -- m is imported by v1 + -- which is imported by v2 + -- ... + -- which is imported by vn + -- It retuns an import chain [w1, w2, ..wm] + -- where w1 imports w2 imports .... imports wm imports w1 + shortest visited m + | m `elem` visited + = m : reverse (takeWhile (/= m) visited) + | otherwise + = minWith length (map (shortest (m:visited)) deps) + where + Just deps = Map.lookup m dep_env + + show_path [] = panic "show_path" + show_path [m] = ptext (sLit "module") <+> quotes (ppr m) + <+> ptext (sLit "imports itself") + show_path (m1:m2:ms) = ptext (sLit "module") <+> quotes (ppr m1) + <+> sep ( nest 6 (ptext (sLit "imports") <+> quotes (ppr m2)) + : go ms) + where + go [] = [ptext (sLit "which imports") <+> quotes (ppr m1)] + go (m:ms) = (ptext (sLit "which imports") <+> quotes (ppr m)) : go ms + +minWith :: Ord b => (a -> b) -> [a] -> a +minWith get_key xs = ASSERT( not (null xs) ) + head (sortWith get_key xs)