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))
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
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
(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)
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.
:: 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])
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
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
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
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)
projects / ghc-hetmet.git / blobdiff