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.
parent 55fe4268
......@@ -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
......
......@@ -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))
......
......@@ -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}
......@@ -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 ""
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment