Commit a8dc65d6 authored by Ben.Lippmeier@anu.edu.au's avatar Ben.Lippmeier@anu.edu.au
Browse files

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 ...@@ -412,12 +412,16 @@ runPipeline
-> Maybe ModLocation -- A ModLocation, if this is a Haskell module -> Maybe ModLocation -- A ModLocation, if this is a Haskell module
-> IO (DynFlags, FilePath) -- (final flags, output filename) -> 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 = do
let (input_basename, suffix) = splitFilename input_fn let
(input_basename, suffix) = splitFilename input_fn
basename | Just b <- mb_basename = b basename | Just b <- mb_basename = b
| otherwise = input_basename | 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 -- If we were given a -x flag, then use that phase to start from
start_phase = fromMaybe (startPhase suffix) mb_phase start_phase = fromMaybe (startPhase suffix) mb_phase
......
...@@ -54,7 +54,7 @@ module DynFlags ( ...@@ -54,7 +54,7 @@ module DynFlags (
#include "HsVersions.h" #include "HsVersions.h"
import Module ( Module, mkModuleName, mkModule ) import Module ( Module, mkModuleName, mkModule, ModLocation )
import PackageConfig import PackageConfig
import PrelNames ( mAIN ) import PrelNames ( mAIN )
#ifdef i386_TARGET_ARCH #ifdef i386_TARGET_ARCH
...@@ -142,6 +142,7 @@ data DynFlag ...@@ -142,6 +142,7 @@ data DynFlag
| Opt_D_dump_minimal_imports | Opt_D_dump_minimal_imports
| Opt_D_dump_mod_cycles | Opt_D_dump_mod_cycles
| Opt_D_faststring_stats | Opt_D_faststring_stats
| Opt_DumpToFile -- Redirect dump output to files instead of stdout.
| Opt_DoCoreLinting | Opt_DoCoreLinting
| Opt_DoStgLinting | Opt_DoStgLinting
| Opt_DoCmmLinting | Opt_DoCmmLinting
...@@ -264,7 +265,7 @@ data DynFlag ...@@ -264,7 +265,7 @@ data DynFlag
| Opt_KeepRawSFiles | Opt_KeepRawSFiles
| Opt_KeepTmpFiles | Opt_KeepTmpFiles
deriving (Eq) deriving (Eq, Show)
data DynFlags = DynFlags { data DynFlags = DynFlags {
ghcMode :: GhcMode, ghcMode :: GhcMode,
...@@ -307,6 +308,14 @@ data DynFlags = DynFlags { ...@@ -307,6 +308,14 @@ data DynFlags = DynFlags {
outputFile :: Maybe String, outputFile :: Maybe String,
outputHi :: 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], includePaths :: [String],
libraryPaths :: [String], libraryPaths :: [String],
frameworkPaths :: [String], -- used on darwin only frameworkPaths :: [String], -- used on darwin only
...@@ -466,6 +475,8 @@ defaultDynFlags = ...@@ -466,6 +475,8 @@ defaultDynFlags =
outputFile = Nothing, outputFile = Nothing,
outputHi = Nothing, outputHi = Nothing,
dumpPrefix = Nothing,
dumpPrefixForce = Nothing,
includePaths = [], includePaths = [],
libraryPaths = [], libraryPaths = [],
frameworkPaths = [], frameworkPaths = [],
...@@ -558,6 +569,8 @@ setHcSuf f d = d{ hcSuf = f} ...@@ -558,6 +569,8 @@ setHcSuf f d = d{ hcSuf = f}
setOutputFile f d = d{ outputFile = f} setOutputFile f d = d{ outputFile = f}
setOutputHi f d = d{ outputHi = f} setOutputHi f d = d{ outputHi = f}
setDumpPrefixForce f d = d { dumpPrefixForce = f}
-- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] -- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"]
-- Config.hs should really use Option. -- Config.hs should really use Option.
setPgmP f d = let (pgm:args) = words f in d{ pgm_P = (pgm, map Option args)} setPgmP f d = let (pgm:args) = words f in d{ pgm_P = (pgm, map Option args)}
...@@ -961,6 +974,7 @@ dynamic_flags = [ ...@@ -961,6 +974,7 @@ dynamic_flags = [
, ( "hidir" , HasArg (upd . setHiDir . Just)) , ( "hidir" , HasArg (upd . setHiDir . Just))
, ( "tmpdir" , HasArg (upd . setTmpDir)) , ( "tmpdir" , HasArg (upd . setTmpDir))
, ( "stubdir" , HasArg (upd . setStubDir . Just)) , ( "stubdir" , HasArg (upd . setStubDir . Just))
, ( "ddump-file-prefix", HasArg (upd . setDumpPrefixForce . Just))
------- Keeping temporary files ------------------------------------- ------- Keeping temporary files -------------------------------------
-- These can be singular (think ghc -c) or plural (think ghc --make) -- These can be singular (think ghc -c) or plural (think ghc --make)
...@@ -1052,7 +1066,7 @@ dynamic_flags = [ ...@@ -1052,7 +1066,7 @@ dynamic_flags = [
, ( "ddump-vect", setDumpFlag Opt_D_dump_vect) , ( "ddump-vect", setDumpFlag Opt_D_dump_vect)
, ( "ddump-hpc", setDumpFlag Opt_D_dump_hpc) , ( "ddump-hpc", setDumpFlag Opt_D_dump_hpc)
, ( "ddump-mod-cycles", setDumpFlag Opt_D_dump_mod_cycles) , ( "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)) , ( "ddump-hi-diffs", NoArg (setDynFlag Opt_D_dump_hi_diffs))
, ( "dcore-lint", NoArg (setDynFlag Opt_DoCoreLinting)) , ( "dcore-lint", NoArg (setDynFlag Opt_DoCoreLinting))
, ( "dstg-lint", NoArg (setDynFlag Opt_DoStgLinting)) , ( "dstg-lint", NoArg (setDynFlag Opt_DoStgLinting))
......
...@@ -29,6 +29,7 @@ module ErrUtils ( ...@@ -29,6 +29,7 @@ module ErrUtils (
#include "HsVersions.h" #include "HsVersions.h"
import Module ( ModLocation(..))
import Bag ( Bag, bagToList, isEmptyBag, emptyBag ) import Bag ( Bag, bagToList, isEmptyBag, emptyBag )
import SrcLoc ( SrcSpan ) import SrcLoc ( SrcSpan )
import Util ( sortLe ) import Util ( sortLe )
...@@ -39,7 +40,8 @@ import StaticFlags ( opt_ErrorSpans ) ...@@ -39,7 +40,8 @@ import StaticFlags ( opt_ErrorSpans )
import System.Exit ( ExitCode(..), exitWith ) import System.Exit ( ExitCode(..), exitWith )
import Data.Dynamic import Data.Dynamic
import Data.List
import System.IO
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- Basic error messages: just render a message with a source location. -- Basic error messages: just render a message with a source location.
...@@ -167,17 +169,15 @@ printBagOfWarnings dflags bag_of_warns ...@@ -167,17 +169,15 @@ printBagOfWarnings dflags bag_of_warns
LT -> True LT -> True
EQ -> True EQ -> True
GT -> False GT -> False
\end{code}
\begin{code}
ghcExit :: DynFlags -> Int -> IO () ghcExit :: DynFlags -> Int -> IO ()
ghcExit dflags val ghcExit dflags val
| val == 0 = exitWith ExitSuccess | val == 0 = exitWith ExitSuccess
| otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n") | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n")
exitWith (ExitFailure val) exitWith (ExitFailure val)
\end{code}
\begin{code}
doIfSet :: Bool -> IO () -> IO () doIfSet :: Bool -> IO () -> IO ()
doIfSet flag action | flag = action doIfSet flag action | flag = action
| otherwise = return () | otherwise = return ()
...@@ -185,9 +185,10 @@ doIfSet flag action | flag = action ...@@ -185,9 +185,10 @@ doIfSet flag action | flag = action
doIfSet_dyn :: DynFlags -> DynFlag -> IO () -> IO() doIfSet_dyn :: DynFlags -> DynFlag -> IO () -> IO()
doIfSet_dyn dflags flag action | dopt flag dflags = action doIfSet_dyn dflags flag action | dopt flag dflags = action
| otherwise = return () | otherwise = return ()
\end{code}
\begin{code} -- -----------------------------------------------------------------------------
-- Dumping
dumpIfSet :: Bool -> String -> SDoc -> IO () dumpIfSet :: Bool -> String -> SDoc -> IO ()
dumpIfSet flag hdr doc dumpIfSet flag hdr doc
| not flag = return () | not flag = return ()
...@@ -197,13 +198,14 @@ dumpIfSet_core :: DynFlags -> DynFlag -> String -> SDoc -> IO () ...@@ -197,13 +198,14 @@ dumpIfSet_core :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
dumpIfSet_core dflags flag hdr doc dumpIfSet_core dflags flag hdr doc
| dopt flag dflags | dopt flag dflags
|| verbosity dflags >= 4 || 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 () | otherwise = return ()
dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO () dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn dflags flag hdr doc dumpIfSet_dyn dflags flag hdr doc
| dopt flag dflags || verbosity dflags >= 4 | dopt flag dflags || verbosity dflags >= 4
= printDump (mkDumpDoc hdr doc) = writeDump dflags flag (mkDumpDoc hdr doc)
| otherwise | otherwise
= return () = return ()
...@@ -222,6 +224,62 @@ mkDumpDoc hdr doc ...@@ -222,6 +224,62 @@ mkDumpDoc hdr doc
where where
line = text (replicate 20 '=') 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 -- Outputting messages from the compiler
...@@ -255,4 +313,5 @@ showPass dflags what ...@@ -255,4 +313,5 @@ showPass dflags what
debugTraceMsg :: DynFlags -> Int -> Message -> IO () debugTraceMsg :: DynFlags -> Int -> Message -> IO ()
debugTraceMsg dflags val msg debugTraceMsg dflags val msg
= ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg) = ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg)
\end{code} \end{code}
...@@ -36,7 +36,7 @@ module Outputable ( ...@@ -36,7 +36,7 @@ module Outputable (
hang, punctuate, hang, punctuate,
speakNth, speakNTimes, speakN, speakNOf, plural, speakNth, speakNTimes, speakN, speakNOf, plural,
printSDoc, printErrs, printDump, printSDoc, printErrs, hPrintDump, printDump,
printForC, printForAsm, printForUser, printForC, printForAsm, printForUser,
pprCode, mkCodeStyle, pprCode, mkCodeStyle,
showSDoc, showSDocForUser, showSDocDebug, showSDocDump, showSDoc, showSDocForUser, showSDocDebug, showSDocDump,
...@@ -258,9 +258,12 @@ printErrs doc = do Pretty.printDoc PageMode stderr doc ...@@ -258,9 +258,12 @@ printErrs doc = do Pretty.printDoc PageMode stderr doc
hFlush stderr hFlush stderr
printDump :: SDoc -> IO () printDump :: SDoc -> IO ()
printDump doc = do printDump doc = hPrintDump stdout doc
Pretty.printDoc PageMode stdout (better_doc defaultDumpStyle)
hFlush stdout hPrintDump :: Handle -> SDoc -> IO ()
hPrintDump h doc = do
Pretty.printDoc PageMode h (better_doc defaultDumpStyle)
hFlush h
where where
better_doc = doc $$ text "" 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