From: Ben.Lippmeier@anu.edu.au Date: Tue, 21 Aug 2007 16:31:10 +0000 (+0000) Subject: Allow redirection of -ddump-* to file X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=a8dc65d6582cc8dda6a1de2862e2d6da80a78d0c Allow redirection of -ddump-* to file Whilst compiling Main.hs with -ddump-stg, ddump-asm and friends you can how add -ddump-to-file and you'll get the dumps redirected to Main.dump-stg, Main.dump-asm etc. --- diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 4f19cfa..67fe31d 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -412,12 +412,16 @@ runPipeline -> Maybe ModLocation -- A ModLocation, if this is a Haskell module -> IO (DynFlags, FilePath) -- (final flags, output filename) -runPipeline stop_phase dflags (input_fn, mb_phase) mb_basename output maybe_loc +runPipeline stop_phase dflags0 (input_fn, mb_phase) mb_basename output maybe_loc = do - let (input_basename, suffix) = splitFilename input_fn + let + (input_basename, suffix) = splitFilename input_fn basename | Just b <- mb_basename = b | otherwise = input_basename + -- Decide where dump files should go based on the pipeline output + dflags = dflags0 { dumpPrefix = Just (basename ++ ".") } + -- If we were given a -x flag, then use that phase to start from start_phase = fromMaybe (startPhase suffix) mb_phase diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 5b26155..f2906e7 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -54,7 +54,7 @@ module DynFlags ( #include "HsVersions.h" -import Module ( Module, mkModuleName, mkModule ) +import Module ( Module, mkModuleName, mkModule, ModLocation ) import PackageConfig import PrelNames ( mAIN ) #ifdef i386_TARGET_ARCH @@ -142,11 +142,12 @@ data DynFlag | Opt_D_dump_minimal_imports | Opt_D_dump_mod_cycles | Opt_D_faststring_stats + | Opt_DumpToFile -- Redirect dump output to files instead of stdout. | Opt_DoCoreLinting | Opt_DoStgLinting | Opt_DoCmmLinting - | Opt_WarnIsError -- -Werror; makes warnings fatal + | Opt_WarnIsError -- -Werror; makes warnings fatal | Opt_WarnDuplicateExports | Opt_WarnHiShadows | Opt_WarnImplicitPrelude @@ -264,7 +265,7 @@ data DynFlag | Opt_KeepRawSFiles | Opt_KeepTmpFiles - deriving (Eq) + deriving (Eq, Show) data DynFlags = DynFlags { ghcMode :: GhcMode, @@ -307,6 +308,14 @@ data DynFlags = DynFlags { outputFile :: Maybe String, outputHi :: Maybe String, + -- | This is set by DriverPipeline.runPipeline based on where + -- its output is going. + dumpPrefix :: Maybe FilePath, + + -- | Override the dumpPrefix set by runPipeline. + -- Set by -ddump-file-prefix + dumpPrefixForce :: Maybe FilePath, + includePaths :: [String], libraryPaths :: [String], frameworkPaths :: [String], -- used on darwin only @@ -466,6 +475,8 @@ defaultDynFlags = outputFile = Nothing, outputHi = Nothing, + dumpPrefix = Nothing, + dumpPrefixForce = Nothing, includePaths = [], libraryPaths = [], frameworkPaths = [], @@ -558,6 +569,8 @@ setHcSuf f d = d{ hcSuf = f} setOutputFile f d = d{ outputFile = f} setOutputHi f d = d{ outputHi = f} +setDumpPrefixForce f d = d { dumpPrefixForce = f} + -- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] -- Config.hs should really use Option. setPgmP f d = let (pgm:args) = words f in d{ pgm_P = (pgm, map Option args)} @@ -961,6 +974,7 @@ dynamic_flags = [ , ( "hidir" , HasArg (upd . setHiDir . Just)) , ( "tmpdir" , HasArg (upd . setTmpDir)) , ( "stubdir" , HasArg (upd . setStubDir . Just)) + , ( "ddump-file-prefix", HasArg (upd . setDumpPrefixForce . Just)) ------- Keeping temporary files ------------------------------------- -- These can be singular (think ghc -c) or plural (think ghc --make) @@ -1052,7 +1066,7 @@ dynamic_flags = [ , ( "ddump-vect", setDumpFlag Opt_D_dump_vect) , ( "ddump-hpc", setDumpFlag Opt_D_dump_hpc) , ( "ddump-mod-cycles", setDumpFlag Opt_D_dump_mod_cycles) - + , ( "ddump-to-file", setDumpFlag Opt_DumpToFile) , ( "ddump-hi-diffs", NoArg (setDynFlag Opt_D_dump_hi_diffs)) , ( "dcore-lint", NoArg (setDynFlag Opt_DoCoreLinting)) , ( "dstg-lint", NoArg (setDynFlag Opt_DoStgLinting)) diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index 42cb314..d93fb1b 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -29,6 +29,7 @@ module ErrUtils ( #include "HsVersions.h" +import Module ( ModLocation(..)) import Bag ( Bag, bagToList, isEmptyBag, emptyBag ) import SrcLoc ( SrcSpan ) import Util ( sortLe ) @@ -39,7 +40,8 @@ import StaticFlags ( opt_ErrorSpans ) import System.Exit ( ExitCode(..), exitWith ) import Data.Dynamic - +import Data.List +import System.IO -- ----------------------------------------------------------------------------- -- Basic error messages: just render a message with a source location. @@ -167,17 +169,15 @@ printBagOfWarnings dflags bag_of_warns LT -> True EQ -> True GT -> False -\end{code} -\begin{code} + + ghcExit :: DynFlags -> Int -> IO () ghcExit dflags val | val == 0 = exitWith ExitSuccess | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n") exitWith (ExitFailure val) -\end{code} -\begin{code} doIfSet :: Bool -> IO () -> IO () doIfSet flag action | flag = action | otherwise = return () @@ -185,9 +185,10 @@ doIfSet flag action | flag = action doIfSet_dyn :: DynFlags -> DynFlag -> IO () -> IO() doIfSet_dyn dflags flag action | dopt flag dflags = action | otherwise = return () -\end{code} -\begin{code} +-- ----------------------------------------------------------------------------- +-- Dumping + dumpIfSet :: Bool -> String -> SDoc -> IO () dumpIfSet flag hdr doc | not flag = return () @@ -197,13 +198,14 @@ dumpIfSet_core :: DynFlags -> DynFlag -> String -> SDoc -> IO () dumpIfSet_core dflags flag hdr doc | dopt flag dflags || verbosity dflags >= 4 - || dopt Opt_D_verbose_core2core dflags = printDump (mkDumpDoc hdr doc) + || dopt Opt_D_verbose_core2core dflags + = writeDump dflags flag (mkDumpDoc hdr doc) | otherwise = return () dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO () dumpIfSet_dyn dflags flag hdr doc | dopt flag dflags || verbosity dflags >= 4 - = printDump (mkDumpDoc hdr doc) + = writeDump dflags flag (mkDumpDoc hdr doc) | otherwise = return () @@ -222,6 +224,62 @@ mkDumpDoc hdr doc where line = text (replicate 20 '=') + +-- | Write out a dump. +-- If --dump-to-file is set then this goes to a file. +-- otherwise emit to stdout. +writeDump :: DynFlags -> DynFlag -> SDoc -> IO () +writeDump dflags dflag doc + = do let mFile = chooseDumpFile dflags dflag + case mFile of + -- write the dump to a file + Just fileName + -> do handle <- openFile fileName AppendMode + hPrintDump handle doc + hClose handle + + -- write the dump to stdout + Nothing + -> do printDump doc + + +-- | Choose where to put a dump file based on DynFlags +-- +chooseDumpFile :: DynFlags -> DynFlag -> Maybe String +chooseDumpFile dflags dflag + + -- dump file location is being forced + -- by the --ddump-file-prefix flag. + | dumpToFile + , Just prefix <- dumpPrefixForce dflags + = Just $ prefix ++ (beautifyDumpName dflag) + + -- dump file location chosen by DriverPipeline.runPipeline + | dumpToFile + , Just prefix <- dumpPrefix dflags + = Just $ prefix ++ (beautifyDumpName dflag) + + -- we haven't got a place to put a dump file. + | otherwise + = Nothing + + where dumpToFile = dopt Opt_DumpToFile dflags + + +-- | Build a nice file name from name of a DynFlag constructor +beautifyDumpName :: DynFlag -> String +beautifyDumpName dflag + = let str = show dflag + cut = if isPrefixOf "Opt_D_" str + then drop 6 str + else str + dash = map (\c -> case c of + '_' -> '-' + _ -> c) + cut + in dash + + -- ----------------------------------------------------------------------------- -- Outputting messages from the compiler @@ -255,4 +313,5 @@ showPass dflags what debugTraceMsg :: DynFlags -> Int -> Message -> IO () debugTraceMsg dflags val msg = ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg) + \end{code} diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index 6d9132e..84e71d0 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -36,7 +36,7 @@ module Outputable ( hang, punctuate, speakNth, speakNTimes, speakN, speakNOf, plural, - printSDoc, printErrs, printDump, + printSDoc, printErrs, hPrintDump, printDump, printForC, printForAsm, printForUser, pprCode, mkCodeStyle, showSDoc, showSDocForUser, showSDocDebug, showSDocDump, @@ -258,9 +258,12 @@ printErrs doc = do Pretty.printDoc PageMode stderr doc hFlush stderr printDump :: SDoc -> IO () -printDump doc = do - Pretty.printDoc PageMode stdout (better_doc defaultDumpStyle) - hFlush stdout +printDump doc = hPrintDump stdout doc + +hPrintDump :: Handle -> SDoc -> IO () +hPrintDump h doc = do + Pretty.printDoc PageMode h (better_doc defaultDumpStyle) + hFlush h where better_doc = doc $$ text ""