[commit: ghc] master: Implement -dsuppress-unfoldings (a0e8bb7)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/a0e8bb74e734c65e8f7466f6f2d4f64666f871d8/ghc

>---------------------------------------------------------------

commit a0e8bb74e734c65e8f7466f6f2d4f64666f871d8
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Thu Jul 9 13:22:24 2015 +0100

    Implement -dsuppress-unfoldings
    
    This extra "suppress" flag helps when there are a lot of Ids
    with big unfoldings that clutter up the dump
    
    Also slightly refactor printing of coercions in Core


>---------------------------------------------------------------

a0e8bb74e734c65e8f7466f6f2d4f64666f871d8
 compiler/coreSyn/PprCore.hs                        | 32 ++++++++++------------
 compiler/main/DynFlags.hs                          |  3 ++
 .../tests/deSugar/should_compile/T2431.stderr      |  4 +--
 3 files changed, 19 insertions(+), 20 deletions(-)

diff --git a/compiler/coreSyn/PprCore.hs b/compiler/coreSyn/PprCore.hs
index e33c115..2ae1577 100644
--- a/compiler/coreSyn/PprCore.hs
+++ b/compiler/coreSyn/PprCore.hs
@@ -120,6 +120,12 @@ pprCoreExpr   expr = ppr_expr noParens expr
 noParens :: SDoc -> SDoc
 noParens pp = pp
 
+pprOptCo :: Coercion -> SDoc
+pprOptCo co = sdocWithDynFlags $ \dflags ->
+              if gopt Opt_SuppressCoercions dflags
+              then ptext (sLit "...")
+              else parens (sep [ppr co, dcolon <+> ppr (coercionType co)])
+
 ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
         -- The function adds parens in context that need
         -- an atomic value (e.g. function args)
@@ -130,16 +136,7 @@ ppr_expr add_par (Coercion co) = add_par (ptext (sLit "CO") <+> ppr co)
 ppr_expr add_par (Lit lit)     = pprLiteral add_par lit
 
 ppr_expr add_par (Cast expr co)
-  = add_par $
-    sep [pprParendExpr expr,
-         ptext (sLit "`cast`") <+> pprCo co]
-  where
-    pprCo co = sdocWithDynFlags $ \dflags ->
-               if gopt Opt_SuppressCoercions dflags
-               then ptext (sLit "...")
-               else parens $
-                        sep [ppr co, dcolon <+> ppr (coercionType co)]
-
+  = add_par $ sep [pprParendExpr expr, ptext (sLit "`cast`") <+> pprOptCo co]
 
 ppr_expr add_par expr@(Lam _ _)
   = let
@@ -271,7 +268,7 @@ pprArg (Type ty)
    if gopt Opt_SuppressTypeApplications dflags
    then empty
    else ptext (sLit "@") <+> pprParendType ty
-pprArg (Coercion co) = ptext (sLit "@~") <+> pprParendCo co
+pprArg (Coercion co) = ptext (sLit "@~") <+> pprOptCo co
 pprArg expr          = pprParendExpr expr
 
 {-
@@ -361,9 +358,8 @@ pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)
 pprIdBndrInfo :: IdInfo -> SDoc
 pprIdBndrInfo info
   = sdocWithDynFlags $ \dflags ->
-    if gopt Opt_SuppressIdInfo dflags
-    then empty
-    else info `seq` doc -- The seq is useful for poking on black holes
+    ppUnless (gopt Opt_SuppressIdInfo dflags) $
+    info `seq` doc -- The seq is useful for poking on black holes
   where
     prag_info = inlinePragInfo info
     occ_info  = occInfo info
@@ -391,9 +387,7 @@ pprIdBndrInfo info
 ppIdInfo :: Id -> IdInfo -> SDoc
 ppIdInfo id info
   = sdocWithDynFlags $ \dflags ->
-    if gopt Opt_SuppressIdInfo dflags
-    then empty
-    else
+    ppUnless (gopt Opt_SuppressIdInfo dflags) $
     showAttributes
     [ (True, pp_scope <> ppr (idDetails id))
     , (has_arity,        ptext (sLit "Arity=") <> int arity)
@@ -478,7 +472,9 @@ instance Outputable Unfolding where
                 , ptext (sLit "WorkFree=")   <> ppr wf
                 , ptext (sLit "Expandable=") <> ppr exp
                 , ptext (sLit "Guidance=")   <> ppr g ]
-      pp_tmpl = ptext (sLit "Tmpl=") <+> ppr rhs
+      pp_tmpl = sdocWithDynFlags $ \dflags ->
+                ppUnless (gopt Opt_SuppressUnfoldings dflags) $
+                ptext (sLit "Tmpl=") <+> ppr rhs
       pp_rhs | isStableSource src = pp_tmpl
              | otherwise          = empty
             -- Don't print the RHS or we get a quadratic
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 70981e7..ad604c8 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -442,6 +442,8 @@ data GeneralFlag
    | Opt_SuppressIdInfo
    -- Suppress separate type signatures in core, but leave types on
    -- lambda bound vars
+   | Opt_SuppressUnfoldings
+   -- Suppress the details of even stable unfoldings
    | Opt_SuppressTypeSignatures
    -- Suppress unique ids on variables.
    -- Except for uniques, as some simplifier phases introduce new
@@ -2905,6 +2907,7 @@ dFlags = [
   flagSpec "ppr-ticks"                  Opt_PprShowTicks,
   flagSpec "suppress-coercions"         Opt_SuppressCoercions,
   flagSpec "suppress-idinfo"            Opt_SuppressIdInfo,
+  flagSpec "suppress-unfoldings"        Opt_SuppressUnfoldings,
   flagSpec "suppress-module-prefixes"   Opt_SuppressModulePrefixes,
   flagSpec "suppress-type-applications" Opt_SuppressTypeApplications,
   flagSpec "suppress-type-signatures"   Opt_SuppressTypeSignatures,
diff --git a/testsuite/tests/deSugar/should_compile/T2431.stderr b/testsuite/tests/deSugar/should_compile/T2431.stderr
index f2b5ee6..cd14bd1 100644
--- a/testsuite/tests/deSugar/should_compile/T2431.stderr
+++ b/testsuite/tests/deSugar/should_compile/T2431.stderr
@@ -10,8 +10,8 @@ T2431.$WRefl [InlPrag=INLINE] :: forall a. a :~: a
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=0,unsat_ok=False,boring_ok=False)
-         Tmpl= \ (@ a) -> T2431.Refl @ a @ a @~ <a>_N}]
-T2431.$WRefl = \ (@ a) -> T2431.Refl @ a @ a @~ <a>_N
+         Tmpl= \ (@ a) -> T2431.Refl @ a @ a @~ (<a>_N :: a ~# a)}]
+T2431.$WRefl = \ (@ a) -> T2431.Refl @ a @ a @~ (<a>_N :: a ~# a)
 
 -- RHS size: {terms: 4, types: 7, coercions: 0}
 absurd :: forall a. Int :~: Bool -> a