[commit: ghc] master: Make -dppr-cols a dynamic flag (e6e3a96)
Ian Lynagh
igloo at earth.li
Wed Jun 20 14:35:10 CEST 2012
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : master
http://hackage.haskell.org/trac/ghc/changeset/e6e3a960b23efa683bc04203d794e867a6c1bb27
>---------------------------------------------------------------
commit e6e3a960b23efa683bc04203d794e867a6c1bb27
Author: Ian Lynagh <igloo at earth.li>
Date: Mon Jun 18 21:02:31 2012 +0100
Make -dppr-cols a dynamic flag
>---------------------------------------------------------------
compiler/main/DynFlags.hs | 6 +++++-
compiler/main/DynFlags.hs-boot | 1 +
compiler/main/StaticFlags.hs | 14 --------------
compiler/nativeGen/AsmCodeGen.lhs | 2 +-
compiler/utils/Outputable.lhs | 12 ++++++------
compiler/utils/Pretty.lhs | 9 +++------
docs/users_guide/flags.xml | 2 +-
7 files changed, 17 insertions(+), 29 deletions(-)
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index dee30e8..0907484 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -616,6 +616,7 @@ data DynFlags = DynFlags {
-- Output style options
pprUserLength :: Int,
+ pprCols :: Int,
traceLevel :: Int, -- Standard level is 1. Less verbose is 0.
-- | what kind of {-# SCC #-} to add automatically
@@ -975,6 +976,7 @@ defaultDynFlags mySettings =
flushOut = defaultFlushOut,
flushErr = defaultFlushErr,
pprUserLength = 5,
+ pprCols = 100,
traceLevel = 1,
profAuto = NoProfAuto,
llvmVersion = panic "defaultDynFlags: No llvmVersion"
@@ -1013,7 +1015,8 @@ defaultLogAction dflags severity srcSpan style msg
defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO ()
defaultLogActionHPrintDoc dflags h d sty
- = do Pretty.printDoc Pretty.PageMode h (runSDoc d (initSDocContext dflags sty))
+ = do let doc = runSDoc d (initSDocContext dflags sty)
+ Pretty.printDoc Pretty.PageMode (pprCols dflags) h doc
hFlush h
newtype FlushOut = FlushOut (IO ())
@@ -1620,6 +1623,7 @@ dynamic_flags = [
------ Output style options -----------------------------------------
, Flag "dppr-user-length" (intSuffix (\n d -> d{ pprUserLength = n }))
+ , Flag "dppr-cols" (intSuffix (\n d -> d{ pprCols = n }))
, Flag "dtrace-level" (intSuffix (\n d -> d{ traceLevel = n }))
------ Debugging ----------------------------------------------------
diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot
index 12489a6..9f14d41 100644
--- a/compiler/main/DynFlags.hs-boot
+++ b/compiler/main/DynFlags.hs-boot
@@ -9,4 +9,5 @@ tracingDynFlags :: DynFlags
targetPlatform :: DynFlags -> Platform
pprUserLength :: DynFlags -> Int
+pprCols :: DynFlags -> Int
diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs
index 87f24d0..94e1986 100644
--- a/compiler/main/StaticFlags.hs
+++ b/compiler/main/StaticFlags.hs
@@ -27,7 +27,6 @@ module StaticFlags (
WayName(..), Way(..), v_Ways, isRTSWay, mkBuildTag,
-- Output style options
- opt_PprCols,
opt_PprStyle_Debug,
opt_NoDebugOutput,
@@ -249,19 +248,6 @@ opt_SuppressUniques :: Bool
opt_SuppressUniques
= lookUp (fsLit "-dsuppress-uniques")
--- | Set the maximum width of the dumps
--- If GHC's command line options are bad then the options parser uses the
--- pretty printer display the error message. In this case the staticFlags
--- won't be initialized yet, so we must check for this case explicitly
--- and return the default value.
-opt_PprCols :: Int
-opt_PprCols
- = unsafePerformIO
- $ do ready <- readIORef v_opt_C_ready
- if (not ready)
- then return 100
- else return $ lookup_def_int "-dppr-cols" 100
-
opt_PprStyle_Debug :: Bool
opt_PprStyle_Debug = lookUp (fsLit "-dppr-debug")
diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index 93e282f..86f82f7 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -259,7 +259,7 @@ nativeCodeGen' dflags ncgImpl h us cmms
$ Linear.pprStats (concat native) stats)
-- write out the imports
- Pretty.printDoc Pretty.LeftMode h
+ Pretty.printDoc Pretty.LeftMode (pprCols dflags) h
$ withPprStyleDoc dflags (mkCodeStyle AsmStyle)
$ makeImportsDoc dflags (concat imports)
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index cbe4f84..93dfd33 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -72,7 +72,7 @@ module Outputable (
) where
import {-# SOURCE #-} DynFlags( DynFlags, tracingDynFlags,
- targetPlatform, pprUserLength )
+ targetPlatform, pprUserLength, pprCols )
import {-# SOURCE #-} Module( Module, ModuleName, moduleName )
import {-# SOURCE #-} Name( Name, nameModule )
@@ -332,7 +332,7 @@ ifPprDebug d = SDoc $ \ctx ->
\begin{code}
hPrintDump :: DynFlags -> Handle -> SDoc -> IO ()
hPrintDump dflags h doc = do
- Pretty.printDoc PageMode h
+ Pretty.printDoc PageMode (pprCols dflags) h
(runSDoc better_doc (initSDocContext dflags defaultDumpStyle))
hFlush h
where
@@ -340,24 +340,24 @@ hPrintDump dflags h doc = do
printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO ()
printForUser dflags handle unqual doc
- = Pretty.printDoc PageMode handle
+ = Pretty.printDoc PageMode (pprCols dflags) handle
(runSDoc doc (initSDocContext dflags (mkUserStyle unqual AllTheWay)))
printForUserPartWay :: DynFlags -> Handle -> Int -> PrintUnqualified -> SDoc
-> IO ()
printForUserPartWay dflags handle d unqual doc
- = Pretty.printDoc PageMode handle
+ = Pretty.printDoc PageMode (pprCols dflags) handle
(runSDoc doc (initSDocContext dflags (mkUserStyle unqual (PartWay d))))
-- printForC, printForAsm do what they sound like
printForC :: DynFlags -> Handle -> SDoc -> IO ()
printForC dflags handle doc =
- Pretty.printDoc LeftMode handle
+ Pretty.printDoc LeftMode (pprCols dflags) handle
(runSDoc doc (initSDocContext dflags (PprCode CStyle)))
printForAsm :: DynFlags -> Handle -> SDoc -> IO ()
printForAsm dflags handle doc =
- Pretty.printDoc LeftMode handle
+ Pretty.printDoc LeftMode (pprCols dflags) handle
(runSDoc doc (initSDocContext dflags (PprCode AsmStyle)))
pprCode :: CodeStyle -> SDoc -> SDoc
diff --git a/compiler/utils/Pretty.lhs b/compiler/utils/Pretty.lhs
index cc8f235..abe8957 100644
--- a/compiler/utils/Pretty.lhs
+++ b/compiler/utils/Pretty.lhs
@@ -1002,13 +1002,10 @@ spaces n | n <=# _ILIT(0) = ""
\end{code}
\begin{code}
-pprCols :: Int
-pprCols = opt_PprCols
-
-printDoc :: Mode -> Handle -> Doc -> IO ()
-printDoc LeftMode hdl doc
+printDoc :: Mode -> Int -> Handle -> Doc -> IO ()
+printDoc LeftMode _ hdl doc
= do { printLeftRender hdl doc; hFlush hdl }
-printDoc mode hdl doc
+printDoc mode pprCols hdl doc
= do { fullRender mode pprCols 1.5 put done doc ;
hFlush hdl }
where
diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml
index db17084..a862029 100644
--- a/docs/users_guide/flags.xml
+++ b/docs/users_guide/flags.xml
@@ -2718,7 +2718,7 @@
<row>
<entry><option>-dppr-colsNNN</option></entry>
<entry>Set the width of debugging output. For example <option>-dppr-cols200</option></entry>
- <entry>static</entry>
+ <entry>dynamic</entry>
<entry>-</entry>
</row>
<row>
More information about the Cvs-ghc
mailing list