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.

4 files changed, 99 insertions, 19 deletions

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 4f19cfab38..67fe31d406 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 5b26155b60..f2906e70d9 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 42cb31474d..d93fb1bdef 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 6d9132e105..84e71d0b06 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 ""