X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FDriverMkDepend.hs;h=af917bd255da5bd746e2f8ef98897270a9d83e63;hb=9221ef240afc2859ce43c5a017e52aa1e6dc51f8;hp=80d906c4a7c0e8b0c91ca2e94029238f877658aa;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs index 80d906c..af917bd 100644 --- a/compiler/main/DriverMkDepend.hs +++ b/compiler/main/DriverMkDepend.hs @@ -14,35 +14,34 @@ module DriverMkDepend ( import qualified GHC import GHC ( Session, ModSummary(..) ) -import DynFlags ( DynFlags( verbosity, opt_dep ), getOpts ) +import DynFlags import Util ( escapeSpaces, splitFilename, joinFileExt ) import HscTypes ( HscEnv, IsBootInterface, msObjFilePath, msHsFilePath ) -import Packages ( PackageIdH(..) ) import SysTools ( newTempName ) import qualified SysTools -import Module ( Module, ModLocation(..), mkModule, - addBootSuffix_maybe ) +import Module import Digraph ( SCC(..) ) -import Finder ( findModule, FindResult(..) ) +import Finder ( findImportedModule, FindResult(..) ) import Util ( global, consIORef ) import Outputable import Panic -import SrcLoc ( unLoc ) +import SrcLoc +import Data.List import CmdLineParser #if __GLASGOW_HASKELL__ <= 408 import Panic ( catchJust, ioErrors ) #endif -import ErrUtils ( debugTraceMsg, printErrorsAndWarnings ) +import ErrUtils ( debugTraceMsg, putMsg ) -import DATA_IOREF ( IORef, readIORef, writeIORef ) -import EXCEPTION - -import System ( ExitCode(..), exitWith ) -import Directory -import IO -import Monad ( when ) -import Maybe ( isJust ) +import Data.IORef ( IORef, readIORef, writeIORef ) +import Control.Exception +import System.Exit ( ExitCode(..), exitWith ) +import System.Directory +import System.IO +import SYSTEM_IO_ERROR ( isEOFError ) +import Control.Monad ( when ) +import Data.Maybe ( isJust ) ----------------------------------------------------------------- -- @@ -76,6 +75,9 @@ doMkDependHS session srcs -- and complaining about cycles ; mapM (processDeps session excl_mods (mkd_tmp_hdl files)) sorted + -- If -ddump-mod-cycles, show cycles in the module graph + ; dumpModCycles dflags mod_summaries + -- Tidy up ; endMkDependHS dflags files }} @@ -153,7 +155,7 @@ beginMkDependHS dflags = do ----------------------------------------------------------------- processDeps :: Session - -> [Module] + -> [ModuleName] -> Handle -- Write dependencies to here -> SCC ModSummary -> IO () @@ -217,24 +219,24 @@ processDeps session excl_mods hdl (AcyclicSCC node) findDependency :: HscEnv -> FilePath -- Importing module: used only for error msg - -> Module -- Imported module + -> ModuleName -- Imported module -> IsBootInterface -- Source import -> Bool -- Record dependency on package modules -> IO (Maybe FilePath) -- Interface file file findDependency hsc_env src imp is_boot include_pkg_deps = do { -- Find the module; this will be fast because -- we've done it once during downsweep - r <- findModule hsc_env imp True {-explicit-} + r <- findImportedModule hsc_env imp Nothing ; case r of - Found loc pkg - -- Not in this package: we don't need a dependency - | ExtPackage _ <- pkg, not include_pkg_deps - -> return Nothing - + Found loc mod -- Home package: just depend on the .hi or hi-boot file - | otherwise + | isJust (ml_hs_file loc) -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc))) + -- Not in this package: we don't need a dependency + | otherwise + -> return Nothing + _ -> panic "findDependency" } @@ -314,6 +316,67 @@ endMkDependHS dflags ----------------------------------------------------------------- +-- Module cycles +----------------------------------------------------------------- + +dumpModCycles :: DynFlags -> [ModSummary] -> IO () +dumpModCycles dflags mod_summaries + | not (dopt Opt_D_dump_mod_cycles dflags) + = return () + + | null cycles + = putMsg dflags (ptext SLIT("No module cycles")) + + | otherwise + = putMsg dflags (hang (ptext SLIT("Module cycles found:")) 2 pp_cycles) + where + + cycles :: [[ModSummary]] + cycles = [ c | CyclicSCC c <- GHC.topSortModuleGraph True mod_summaries Nothing ] + + pp_cycles = vcat [ (ptext SLIT("---------- Cycle") <+> int n <+> ptext SLIT("----------")) + $$ pprCycle c $$ text "" + | (n,c) <- [1..] `zip` cycles ] + +pprCycle :: [ModSummary] -> SDoc +-- Print a cycle, but show only the imports within the cycle +pprCycle summaries = pp_group (CyclicSCC summaries) + where + cycle_mods :: [ModuleName] -- The modules in this cycle + cycle_mods = map (moduleName . ms_mod) summaries + + pp_group (AcyclicSCC ms) = pp_ms ms + pp_group (CyclicSCC mss) + = ASSERT( not (null boot_only) ) + -- The boot-only list must be non-empty, else there would + -- be an infinite chain of non-boot imoprts, and we've + -- already checked for that in processModDeps + pp_ms loop_breaker $$ vcat (map pp_group groups) + where + (boot_only, others) = partition is_boot_only mss + is_boot_only ms = not (any in_group (ms_imps ms)) + in_group (L _ m) = m `elem` group_mods + group_mods = map (moduleName . ms_mod) mss + + loop_breaker = head boot_only + all_others = tail boot_only ++ others + groups = GHC.topSortModuleGraph True all_others Nothing + + pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' ')) + <+> (pp_imps empty (ms_imps summary) $$ + pp_imps (ptext SLIT("{-# SOURCE #-}")) (ms_srcimps summary)) + where + mod_str = moduleNameString (moduleName (ms_mod summary)) + + pp_imps :: SDoc -> [Located ModuleName] -> SDoc + pp_imps what [] = empty + pp_imps what lms + = case [m | L _ m <- lms, m `elem` cycle_mods] of + [] -> empty + ms -> what <+> ptext SLIT("imports") <+> + pprWithCommas ppr ms + +----------------------------------------------------------------- -- -- Flags -- @@ -322,7 +385,7 @@ endMkDependHS dflags -- Flags GLOBAL_VAR(v_Dep_makefile, "Makefile", String); GLOBAL_VAR(v_Dep_include_pkg_deps, False, Bool); -GLOBAL_VAR(v_Dep_exclude_mods, [], [Module]); +GLOBAL_VAR(v_Dep_exclude_mods, [], [ModuleName]); GLOBAL_VAR(v_Dep_suffixes, [], [String]); GLOBAL_VAR(v_Dep_warnings, True, Bool); @@ -335,8 +398,12 @@ dep_opts = [ ( "s", SepArg (consIORef v_Dep_suffixes) ) , ( "f", SepArg (writeIORef v_Dep_makefile) ) , ( "w", NoArg (writeIORef v_Dep_warnings False) ) + , ( "-include-prelude", NoArg (writeIORef v_Dep_include_pkg_deps True) ) + -- -include-prelude is the old name for -include-pkg-deps, kept around + -- for backward compatibility, but undocumented + , ( "-include-pkg-deps", NoArg (writeIORef v_Dep_include_pkg_deps True) ) - , ( "-exclude-module=", Prefix (consIORef v_Dep_exclude_mods . mkModule) ) - , ( "x", Prefix (consIORef v_Dep_exclude_mods . mkModule) ) + , ( "-exclude-module=", Prefix (consIORef v_Dep_exclude_mods . mkModuleName) ) + , ( "x", Prefix (consIORef v_Dep_exclude_mods . mkModuleName) ) ]