Commit dcf1f926 authored by Chaitanya Koparkar's avatar Chaitanya Koparkar Committed by Ryan Scott

Fix #15953 by consistently using dumpIfSet_dyn to print debug output

Summary:
In some modules we directly dump the debugging output to STDOUT
via 'putLogMsg', 'printInfoForUser' etc. However, if `-ddump-to-file`
is enabled, that output should be written to a file. Easily fixed.

Certain tests (T3017, Roles3, T12763 etc.) expect part of the
output generated by `-ddump-types` to be in 'PprUser' style. However,
generally we want all other debugging output to use 'PprDump'
style. `traceTcRn` and `traceTcRnForUser` help us accomplish this.

This patch also documents some missing flags in the users guide.

Reviewers: RyanGlScott, bgamari, hvr

Reviewed By: RyanGlScott

Subscribers: rwbarton, carter

GHC Trac Issues: #15953

Differential Revision: https://phabricator.haskell.org/D5382
parent 9e3aaf8b
......@@ -93,7 +93,7 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds
, density = mkDensity tickish dflags
, this_mod = mod
, tickishType = tickish
}
}
(binds',_,st') = unTM (addTickLHsBinds binds) env st
in (binds', st')
......@@ -109,9 +109,7 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds
hashNo <- writeMixEntries dflags mod tickCount entries orig_file2
modBreaks <- mkModBreaks hsc_env mod tickCount entries
when (dopt Opt_D_dump_ticked dflags) $
putLogMsg dflags NoReason SevDump noSrcSpan
(defaultDumpStyle dflags) (pprLHsBinds binds1)
dumpIfSet_dyn dflags Opt_D_dump_ticked "HPC" (pprLHsBinds binds1)
return (binds1, HpcInfo tickCount hashNo, Just modBreaks)
......
......@@ -88,9 +88,11 @@ pprintClosureCommand bindThings force str = do
hsc_env <- getSession
case (improveRTTIType hsc_env (idType id) (reconstructed_type)) of
Nothing -> return (subst, term')
Just subst' -> do { traceOptIf Opt_D_dump_rtti
(fsep $ [text "RTTI Improvement for", ppr id,
text "is the substitution:" , ppr subst'])
Just subst' -> do { dflags <- GHC.getSessionDynFlags
; liftIO $
dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI"
(fsep $ [text "RTTI Improvement for", ppr id,
text "is the substitution:" , ppr subst'])
; return (subst `unionTCvSubst` subst', term')}
tidyTermTyVars :: GhcMonad m => Term -> m Term
......@@ -228,11 +230,3 @@ pprTypeAndContents id = do
text (show (exn :: SomeException)))
return $ pprdId <+> equals <+> docs_term
else return pprdId
--------------------------------------------------------------
-- Utils
traceOptIf :: GhcMonad m => DumpFlag -> SDoc -> m ()
traceOptIf flag doc = do
dflags <- GHC.getSessionDynFlags
when (dopt flag dflags) $ liftIO $ printInfoForUser dflags alwaysQualify doc
......@@ -40,7 +40,8 @@ module ErrUtils (
-- * Dump files
dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer,
mkDumpDoc, dumpSDoc,
mkDumpDoc, dumpSDoc, dumpSDocForUser,
dumpSDocWithStyle,
-- * Issuing messages during compilation
putMsg, printInfoForUser, printOutputForUser,
......@@ -480,6 +481,20 @@ withDumpFileHandle dflags flag action = do
action (Just handle)
Nothing -> action Nothing
dumpSDoc, dumpSDocForUser
:: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()
-- | A wrapper around 'dumpSDocWithStyle' which uses 'PprDump' style.
dumpSDoc dflags print_unqual
= dumpSDocWithStyle dump_style dflags
where dump_style = mkDumpStyle dflags print_unqual
-- | A wrapper around 'dumpSDocWithStyle' which uses 'PprUser' style.
dumpSDocForUser dflags print_unqual
= dumpSDocWithStyle user_style dflags
where user_style = mkUserStyle dflags print_unqual AllTheWay
-- | Write out a dump.
-- If --dump-to-file is set then this goes to a file.
-- otherwise emit to stdout.
......@@ -489,12 +504,10 @@ withDumpFileHandle dflags flag action = do
--
-- The 'DumpFlag' is used only to choose the filename to use if @--dump-to-file@
-- is used; it is not used to decide whether to dump the output
dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()
dumpSDoc dflags print_unqual flag hdr doc =
dumpSDocWithStyle :: PprStyle -> DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpSDocWithStyle sty dflags flag hdr doc =
withDumpFileHandle dflags flag writeDump
where
dump_style = mkDumpStyle dflags print_unqual
-- write dump to file
writeDump (Just handle) = do
doc' <- if null hdr
......@@ -507,14 +520,14 @@ dumpSDoc dflags print_unqual flag hdr doc =
$$ blankLine
$$ doc
return $ mkDumpDoc hdr d
defaultLogActionHPrintDoc dflags handle doc' dump_style
defaultLogActionHPrintDoc dflags handle doc' sty
-- write the dump to stdout
writeDump Nothing = do
let (doc', severity)
| null hdr = (doc, SevOutput)
| otherwise = (mkDumpDoc hdr doc, SevDump)
putLogMsg dflags NoReason severity noSrcSpan dump_style doc'
putLogMsg dflags NoReason severity noSrcSpan sty doc'
-- | Choose where to put a dump file based on DynFlags
......
......@@ -576,9 +576,9 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
++ "improvement for a type")) hsc_env
Just subst -> do
let dflags = hsc_dflags hsc_env
when (dopt Opt_D_dump_rtti dflags) $
printInfoForUser dflags alwaysQualify $
fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]
dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI"
(fsep [text "RTTI Improvement for", ppr id, equals,
ppr subst])
let ic' = substInteractiveContext ic subst
return hsc_env{hsc_IC=ic'}
......
......@@ -82,7 +82,7 @@ import Maybes
import System.Environment ( getEnv )
import FastString
import ErrUtils ( debugTraceMsg, MsgDoc, printInfoForUser )
import ErrUtils ( debugTraceMsg, MsgDoc, dumpIfSet_dyn )
import Exception
import System.Directory
......@@ -1583,9 +1583,8 @@ mkPackageState dflags dbs preload0 = do
mod_map2 = mkUnusableModuleToPkgConfAll unusable
mod_map = Map.union mod_map1 mod_map2
when (dopt Opt_D_dump_mod_map dflags) $
printInfoForUser (dflags { pprCols = 200 })
alwaysQualify (pprModuleMap mod_map)
dumpIfSet_dyn (dflags { pprCols = 200 }) Opt_D_dump_mod_map "Mod Map"
(pprModuleMap mod_map)
-- Force pstate to avoid leaking the dflags0 passed to mkPackageState
let !pstate = PackageState{
......
......@@ -59,9 +59,7 @@ import Packages( isDllName )
import HscTypes
import Maybes
import UniqSupply
import ErrUtils (Severity(..))
import Outputable
import SrcLoc
import qualified ErrUtils as Err
import Control.Monad
......@@ -416,14 +414,12 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
-- Print one-line size info
; let cs = coreBindsStats tidy_binds
; when (dopt Opt_D_dump_core_stats dflags)
(putLogMsg dflags NoReason SevDump noSrcSpan
(defaultDumpStyle dflags)
(text "Tidy size (terms,types,coercions)"
<+> ppr (moduleName mod) <> colon
<+> int (cs_tm cs)
<+> int (cs_ty cs)
<+> int (cs_co cs) ))
; Err.dumpIfSet_dyn dflags Opt_D_dump_core_stats "Core Stats"
(text "Tidy size (terms,types,coercions)"
<+> ppr (moduleName mod) <> colon
<+> int (cs_tm cs)
<+> int (cs_ty cs)
<+> int (cs_co cs) )
; return (CgGuts { cg_module = mod,
cg_tycons = alg_tycons,
......
......@@ -34,10 +34,10 @@ import CoreMonad
import Outputable
import FastString
import MonadUtils
import ErrUtils
import ErrUtils as Err
import Panic (throwGhcExceptionIO, GhcException (..))
import BasicTypes ( IntWithInf, treatZeroAsInf, mkIntWithInf )
import Control.Monad ( when, liftM, ap )
import Control.Monad ( liftM, ap )
{-
************************************************************************
......@@ -140,9 +140,8 @@ thenSmpl_ m k
traceSmpl :: String -> SDoc -> SimplM ()
traceSmpl herald doc
= do { dflags <- getDynFlags
; when (dopt Opt_D_dump_simpl_trace dflags) $ liftIO $
printOutputForUser dflags alwaysQualify $
hang (text herald) 2 doc }
; liftIO $ Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_trace "Simpl Trace"
(hang (text herald) 2 doc) }
{-
************************************************************************
......
......@@ -2665,7 +2665,7 @@ tcDump env
-- Dump short output if -ddump-types or -ddump-tc
when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
(printForUserTcRn short_dump) ;
(traceTcRnForUser Opt_D_dump_types short_dump) ;
-- Dump bindings if -ddump-tc
traceOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump);
......
......@@ -42,7 +42,8 @@ module TcRnMonad(
newTcRef, readTcRef, writeTcRef, updTcRef,
-- * Debugging
traceTc, traceRn, traceOptTcRn, traceTcRn,
traceTc, traceRn, traceOptTcRn, traceTcRn, traceTcRnForUser,
traceTcRnWithStyle,
getPrintUnqualified,
printForUserTcRn,
traceIf, traceHiDiffs, traceOptIf,
......@@ -714,18 +715,37 @@ traceOptTcRn flag doc
(traceTcRn flag doc)
}
-- Certain tests (T3017, Roles3, T12763 etc.) expect part of the
-- output generated by `-ddump-types` to be in 'PprUser' style. However,
-- generally we want all other debugging output to use 'PprDump'
-- style. 'traceTcRn' and 'traceTcRnForUser' help us accomplish this.
-- | A wrapper around 'traceTcRnWithStyle' which uses 'PprDump' style.
traceTcRn :: DumpFlag -> SDoc -> TcRn ()
traceTcRn flag doc
= do { dflags <- getDynFlags
; printer <- getPrintUnqualified dflags
; let dump_style = mkDumpStyle dflags printer
; traceTcRnWithStyle dump_style dflags flag doc }
-- | A wrapper around 'traceTcRnWithStyle' which uses 'PprUser' style.
traceTcRnForUser :: DumpFlag -> SDoc -> TcRn ()
-- Used by 'TcRnDriver.tcDump'.
traceTcRnForUser flag doc
= do { dflags <- getDynFlags
; printer <- getPrintUnqualified dflags
; let user_style = mkUserStyle dflags printer AllTheWay
; traceTcRnWithStyle user_style dflags flag doc }
traceTcRnWithStyle :: PprStyle -> DynFlags -> DumpFlag -> SDoc -> TcRn ()
-- ^ Unconditionally dump some trace output
--
-- The DumpFlag is used only to set the output filename
-- for --dump-to-file, not to decide whether or not to output
-- That part is done by the caller
traceTcRn flag doc
= do { dflags <- getDynFlags
; real_doc <- prettyDoc dflags doc
; printer <- getPrintUnqualified dflags
; liftIO $ dumpSDoc dflags printer flag "" real_doc }
traceTcRnWithStyle sty dflags flag doc
= do { real_doc <- prettyDoc dflags doc
; liftIO $ dumpSDocWithStyle sty dflags flag "" real_doc }
where
-- Add current location if -dppr-debug
prettyDoc :: DynFlags -> SDoc -> TcRn SDoc
......
......@@ -32,6 +32,14 @@ Dumping out compiler intermediate structures
output from :ghc-flag:`-ddump-simpl` will end up in
:file:`{module}.dump-simpl`.
.. ghc-flag:: -ddump-file-prefix=⟨str⟩
:shortdesc: Set the prefix of the filenames used for debugging output.
:type: dynamic
Set the prefix of the filenames used for debugging output. For example,
``-ddump-file-prefix=Foo`` will cause the output from
:ghc-flag:`-ddump-simpl` to be dumped to :file:`Foo.dump-simpl`.
.. ghc-flag:: -ddump-json
:shortdesc: Dump error messages as JSON documents
:type: dynamic
......@@ -575,7 +583,41 @@ These flags dump various bits of information from other backends.
Dump foreign export stubs.
.. ghc-flag:: -ddump-ticked
:shortdesc: Dump the code instrumented by HPC (:ref:`hpc`).
:type: dynamic
Dump the code instrumented by HPC (:ref:`hpc`).
.. ghc-flag:: -ddump-hpc
:shortdesc: An alias for :ghc-flag:`-ddump-ticked`.
:type: dynamic
An alias for :ghc-flag:`-ddump-ticked`.
.. ghc-flag:: -ddump-mod-map
:shortdesc: Dump the state of the module mapping database.
:type: dynamic
Dump a mapping of modules to where they come from, and how:
- ``(hidden module)``: Module is hidden, and thus will never be available for
import.
- ``(unusable module)``: Module is unavailable because the package is unusable.
- ``(hidden package)``: This module is in someone's exported-modules list,
but that package is hidden.
- ``(exposed package)``: Module is available for import.
- ``(reexport by <PACKAGES>)``: This module is available from a reexport
of some set of exposed packages.
- ``(hidden reexport by <PACKAGES>)``: This module is available from a reexport
of some set of hidden packages.
- ``(package flag)``: This module export comes from a package flag.
.. _formatting dumps:
......
TOP=../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
T15953:
'$(TEST_HC)' $(TEST_HC_OPTS) T15953.hs
cat T15953.dump-ticked && rm T15953.dump-ticked
cat T15953.dump-simpl-trace && rm T15953.dump-simpl-trace
cat T15953.dump-tc && rm T15953.dump-tc
cat T15953.dump-types && rm T15953.dump-types
cat T15953.dump-core-stats && rm T15953.dump-core-stats
.PHONY: T15953
{-# OPTIONS_GHC -ddump-to-file #-}
{-# OPTIONS_GHC -fhpc -ddump-ticked -ddump-simpl-trace -ddump-tc #-}
{-# OPTIONS_GHC -ddump-types -ddump-core-stats #-}
module T15953 where
foo :: Int -> Int
foo 0 = 0
foo n = foo (n - 1)
......@@ -5,3 +5,5 @@ test('T14854',
ignore_stderr],
compile_and_run,
['-package ghc'])
test('T15953', [ignore_stdout], run_command, ['$MAKE --no-print-directory -s T15953'])
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