X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FDriverMkDepend.hs;h=ef28c2cb30834f4a319d7451e872db3d779137da;hb=bf925fd826e0f7b8a9d58073dbabe0d755ef0266;hp=a0ce1148ab3b979931292ce990dfc76b0e389831;hpb=0079141c61f673039ccd879cd75174b33eb40b8f;p=ghc-hetmet.git diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs index a0ce114..ef28c2c 100644 --- a/compiler/main/DriverMkDepend.hs +++ b/compiler/main/DriverMkDepend.hs @@ -1,3 +1,5 @@ +{-# OPTIONS -fno-cse #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly ----------------------------------------------------------------------------- -- @@ -14,10 +16,10 @@ module DriverMkDepend ( #include "HsVersions.h" import qualified GHC -import GHC ( Session, ModSummary(..) ) +import GHC ( ModSummary(..), GhcMonad ) import DynFlags import Util -import HscTypes ( HscEnv, IsBootInterface, msObjFilePath, msHsFilePath ) +import HscTypes ( HscEnv, IsBootInterface, msObjFilePath, msHsFilePath, getSession ) import SysTools ( newTempName ) import qualified SysTools import Module @@ -27,18 +29,16 @@ import Outputable import Panic import SrcLoc import Data.List -import CmdLineParser import FastString +import Exception import ErrUtils ( debugTraceMsg, putMsg ) +import MonadUtils ( liftIO ) -import Data.IORef ( IORef, readIORef, writeIORef ) -import Control.Exception -import System.Exit ( ExitCode(..), exitWith ) import System.Directory import System.FilePath import System.IO -import SYSTEM_IO_ERROR ( isEOFError ) +import System.IO.Error ( isEOFError ) import Control.Monad ( when ) import Data.Maybe ( isJust ) @@ -48,37 +48,42 @@ import Data.Maybe ( isJust ) -- ----------------------------------------------------------------- -doMkDependHS :: Session -> [FilePath] -> IO () -doMkDependHS session srcs - = do { -- Initialisation - dflags <- GHC.getSessionDynFlags session - ; files <- beginMkDependHS dflags - - -- Do the downsweep to find all the modules - ; targets <- mapM (\s -> GHC.guessTarget s Nothing) srcs - ; GHC.setTargets session targets - ; excl_mods <- readIORef v_Dep_exclude_mods - ; r <- GHC.depanal session excl_mods True {- Allow dup roots -} - ; case r of - Nothing -> exitWith (ExitFailure 1) - Just mod_summaries -> do { +doMkDependHS :: GhcMonad m => [FilePath] -> m () +doMkDependHS srcs = do + -- Initialisation + dflags <- GHC.getSessionDynFlags + files <- liftIO $ beginMkDependHS dflags + + -- Do the downsweep to find all the modules + targets <- mapM (\s -> GHC.guessTarget s Nothing) srcs + GHC.setTargets targets + let excl_mods = depExcludeMods dflags + mod_summaries <- GHC.depanal excl_mods True {- Allow dup roots -} + + -- Sort into dependency order + -- There should be no cycles + let sorted = GHC.topSortModuleGraph False mod_summaries Nothing - -- Sort into dependency order - -- There should be no cycles - let sorted = GHC.topSortModuleGraph False mod_summaries Nothing + -- Print out the dependencies if wanted + liftIO $ debugTraceMsg dflags 2 (text "Module dependencies" $$ ppr sorted) - -- Print out the dependencies if wanted - ; debugTraceMsg dflags 2 (text "Module dependencies" $$ ppr sorted) + -- Prcess them one by one, dumping results into makefile + -- and complaining about cycles + hsc_env <- getSession + mapM (liftIO . processDeps dflags hsc_env excl_mods (mkd_tmp_hdl files)) sorted - -- Prcess them one by one, dumping results into makefile - -- and complaining about cycles - ; mapM (processDeps session excl_mods (mkd_tmp_hdl files)) sorted + -- If -ddump-mod-cycles, show cycles in the module graph + liftIO $ dumpModCycles dflags mod_summaries - -- If -ddump-mod-cycles, show cycles in the module graph - ; dumpModCycles dflags mod_summaries + -- Tidy up + liftIO $ endMkDependHS dflags files - -- Tidy up - ; endMkDependHS dflags files }} + -- Unconditional exiting is a bad idea. If an error occurs we'll get an + --exception; if that is not caught it's fine, but at least we have a + --chance to find out exactly what went wrong. Uncomment the following + --line if you disagree. + + --`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1) ----------------------------------------------------------------- -- @@ -97,17 +102,13 @@ data MkDepFiles beginMkDependHS :: DynFlags -> IO MkDepFiles beginMkDependHS dflags = do - -- slurp in the mkdependHS-style options - let flags = getOpts dflags opt_dep - _ <- processArgs dep_opts flags - -- open a new temp file in which to stuff the dependency info -- as we go along. tmp_file <- newTempName dflags "dep" tmp_hdl <- openFile tmp_file WriteMode -- open the makefile - makefile <- readIORef v_Dep_makefile + let makefile = depMakefile dflags exists <- doesFileExist makefile mb_make_hdl <- if not exists @@ -131,9 +132,9 @@ beginMkDependHS dflags = do then return () else chuck - catchJust ioErrors slurp + catchIO slurp (\e -> if isEOFError e then return () else ioError e) - catchJust ioErrors chuck + catchIO chuck (\e -> if isEOFError e then return () else ioError e) return (Just makefile_hdl) @@ -152,7 +153,8 @@ beginMkDependHS dflags = do -- ----------------------------------------------------------------- -processDeps :: Session +processDeps :: DynFlags + -> HscEnv -> [ModuleName] -> Handle -- Write dependencies to here -> SCC ModSummary @@ -172,15 +174,14 @@ processDeps :: Session -- -- For {-# SOURCE #-} imports the "hi" will be "hi-boot". -processDeps _ _ _ (CyclicSCC nodes) +processDeps _ _ _ _ (CyclicSCC nodes) = -- There shouldn't be any cycles; report them - throwDyn (ProgramError (showSDoc $ GHC.cyclicModuleErr nodes)) + ghcError (ProgramError (showSDoc $ GHC.cyclicModuleErr nodes)) -processDeps session excl_mods hdl (AcyclicSCC node) - = do { extra_suffixes <- readIORef v_Dep_suffixes - ; hsc_env <- GHC.sessionHscEnv session - ; include_pkg_deps <- readIORef v_Dep_include_pkg_deps - ; let src_file = msHsFilePath node +processDeps dflags hsc_env excl_mods hdl (AcyclicSCC node) + = do { let extra_suffixes = depSuffixes dflags + include_pkg_deps = depIncludePkgDeps dflags + src_file = msHsFilePath node obj_file = msObjFilePath node obj_files = insertSuffixes obj_file extra_suffixes @@ -299,7 +300,7 @@ endMkDependHS dflags hPutStrLn tmp_hdl l slurp - catchJust ioErrors slurp + catchIO slurp (\e -> if isEOFError e then return () else ioError e) hClose hdl @@ -382,30 +383,7 @@ pprCycle summaries = pp_group (CyclicSCC summaries) -- ----------------------------------------------------------------- - -- Flags -GLOBAL_VAR(v_Dep_makefile, "Makefile", String); -GLOBAL_VAR(v_Dep_include_pkg_deps, False, Bool); -GLOBAL_VAR(v_Dep_exclude_mods, [], [ModuleName]); -GLOBAL_VAR(v_Dep_suffixes, [], [String]); -GLOBAL_VAR(v_Dep_warnings, True, Bool); - depStartMarker, depEndMarker :: String depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies" depEndMarker = "# DO NOT DELETE: End of Haskell dependencies" --- for compatibility with the old mkDependHS, we accept options of the form --- -optdep-f -optdep.depend, etc. -dep_opts :: [Flag IO] -dep_opts = - [ Flag "s" (SepArg (consIORef v_Dep_suffixes)) - , Flag "f" (SepArg (writeIORef v_Dep_makefile)) - , Flag "w" (NoArg (writeIORef v_Dep_warnings False)) - - , Flag "-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 - - , Flag "-include-pkg-deps" (NoArg (writeIORef v_Dep_include_pkg_deps True)) - , Flag "-exclude-module=" (Prefix (consIORef v_Dep_exclude_mods . mkModuleName)) - , Flag "x" (Prefix (consIORef v_Dep_exclude_mods . mkModuleName)) - ]