Improved debug printing with -dverbose-core2core

(Roman wanted this.)

5 files changed, 41 insertions, 42 deletions

diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index 930041dea4..96a1abdcbe 100644
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -863,7 +863,7 @@ tryUnfolding dflags id lone_variable
 			-- uf_arity will typically be equal to (idArity id), 
 			-- but may be less for InlineRules
  | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags
- = pprTrace ("Considering inlining: " ++ showSDoc (ppr id))
+ = pprTrace ("Considering inlining: " ++ showSDocDump (ppr id))
 		 (vcat [text "arg infos" <+> ppr arg_infos,
 			text "uf arity" <+> ppr uf_arity,
 			text "interesting continuation" <+> ppr cont_info,
diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs
index 829c2ca40f..4af626d053 100644
--- a/compiler/simplCore/CoreMonad.lhs
+++ b/compiler/simplCore/CoreMonad.lhs
@@ -137,7 +137,7 @@ showPass dflags pass = Err.showPass dflags (showSDoc (ppr pass))
 
 endPass :: DynFlags -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
 endPass dflags pass binds rules
-  = do { dumpPassResult dflags mb_flag (ppr pass) empty binds rules
+  = do { dumpPassResult dflags mb_flag (ppr pass) (pprPassDetails pass) binds rules
        ; lintPassResult dflags pass binds }      
   where
     mb_flag = case coreDumpFlag pass of
@@ -167,9 +167,9 @@ dumpPassResult dflags mb_flag hdr extra_info binds rules
 	  -- This has the side effect of forcing the intermediate to be evaluated
 
   where
-    dump_doc  = vcat [ text "Result size =" <+> int (coreBindsSize binds)
-                     , extra_info
-		     , blankLine
+    dump_doc  = vcat [ nest 2 extra_info
+		     , nest 2 (text "Result size =" <+> int (coreBindsSize binds))
+                     , blankLine
                      , pprCoreBindings binds 
                      , ppUnless (null rules) pp_rules ]
     pp_rules = vcat [ blankLine
@@ -307,7 +307,8 @@ instance Outputable CoreToDo where
   ppr (CoreDoPasses {})        = ptext (sLit "CoreDoPasses")
 
 pprPassDetails :: CoreToDo -> SDoc
-pprPassDetails (CoreDoSimplify n md) = ppr md <+> ptext (sLit "max-iterations=") <> int n
+pprPassDetails (CoreDoSimplify n md) = vcat [ ptext (sLit "Max iterations =") <+> int n 
+                                            , ppr md ]
 pprPassDetails _ = empty
 \end{code}
 
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index ee20a52034..b8c8160972 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -1416,7 +1416,7 @@ completeCall env var cont
       	  pprDefiniteTrace "Inlining done:" (ppr var) stuff
         else stuff
       | otherwise
-      = pprDefiniteTrace ("Inlining done: " ++ showSDoc (ppr var))
+      = pprDefiniteTrace ("Inlining done: " ++ showSDocDump (ppr var))
            (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),
                   text "Cont:  " <+> ppr cont])
            stuff
diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index 14235f4651..321deb866a 100644
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -1137,7 +1137,7 @@ specCalls subst rules_for_me calls_for_me fn rhs
 	   ; let
 		-- The rule to put in the function's specialisation is:
 		--	forall b, d1',d2'.  f t1 b t3 d1' d2' = f1 b  
-	        rule_name = mkFastString ("SPEC " ++ showSDoc (ppr fn <+> ppr spec_ty_args))
+	        rule_name = mkFastString ("SPEC " ++ showSDocDump (ppr fn <+> ppr spec_ty_args))
   		spec_env_rule = mkRule True {- Auto generated -} is_local
                                   rule_name
 				  inl_act 	-- Note [Auto-specialisation and RULES]
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index b71389663e..b96ae5e063 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -388,29 +388,29 @@ renderWithStyle sdoc sty =
 -- showSDoc, designed for when we're getting results like "Foo.bar"
 -- and "foo{uniq strictness}" so we don't want fancy layout anyway.
 showSDocOneLine :: SDoc -> String
-showSDocOneLine d =
-  Pretty.showDocWith PageMode
+showSDocOneLine d 
+ = Pretty.showDocWith PageMode
     (runSDoc d (initSDocContext defaultUserStyle))
 
 showSDocForUser :: PrintUnqualified -> SDoc -> String
-showSDocForUser unqual doc =
-  show (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay)))
+showSDocForUser unqual doc
+ = show (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay)))
 
 showSDocUnqual :: SDoc -> String
 -- Only used in the gruesome isOperator
-showSDocUnqual d =
-  show (runSDoc d (initSDocContext (mkUserStyle neverQualify AllTheWay)))
+showSDocUnqual d 
+ = show (runSDoc d (initSDocContext (mkUserStyle neverQualify AllTheWay)))
 
 showsPrecSDoc :: Int -> SDoc -> ShowS
 showsPrecSDoc p d = showsPrec p (runSDoc d (initSDocContext defaultUserStyle))
 
 showSDocDump :: SDoc -> String
-showSDocDump d =
-  Pretty.showDocWith PageMode (runSDoc d (initSDocContext PprDump))
+showSDocDump d 
+ = Pretty.showDocWith PageMode (runSDoc d (initSDocContext defaultDumpStyle))
 
 showSDocDumpOneLine :: SDoc -> String
-showSDocDumpOneLine d =
-  Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext PprDump))
+showSDocDumpOneLine d
+ = Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext PprDump))
 
 showSDocDebug :: SDoc -> String
 showSDocDebug d = show (runSDoc d (initSDocContext PprDebug))
@@ -923,27 +923,27 @@ plural _   = char 's'
 
 pprPanic :: String -> SDoc -> a
 -- ^ Throw an exception saying "bug in GHC"
-pprPanic    = pprAndThen panic
+pprPanic    = pprDebugAndThen panic
 
 pprSorry :: String -> SDoc -> a
 -- ^ Throw an exception saying "this isn't finished yet"
-pprSorry    = pprAndThen sorry
+pprSorry    = pprDebugAndThen sorry
 
 
 pprPgmError :: String -> SDoc -> a
 -- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
-pprPgmError = pprAndThen pgmError
+pprPgmError = pprDebugAndThen pgmError
 
 
 pprTrace :: String -> SDoc -> a -> a
 -- ^ If debug output is on, show some 'SDoc' on the screen
 pprTrace str doc x
    | opt_NoDebugOutput = x
-   | otherwise         = pprAndThen trace str doc x
+   | otherwise         = pprDebugAndThen trace str doc x
 
 pprDefiniteTrace :: String -> SDoc -> a -> a
 -- ^ Same as pprTrace, but show even if -dno-debug-output is on
-pprDefiniteTrace str doc x = pprAndThen trace str doc x
+pprDefiniteTrace str doc x = pprDebugAndThen trace str doc x
 
 pprPanicFastInt :: String -> SDoc -> FastInt
 -- ^ Specialization of pprPanic that can be safely used with 'FastInt'
@@ -952,33 +952,31 @@ pprPanicFastInt heading pretty_msg =
   where
     doc = text heading <+> pretty_msg
 
-
-pprAndThen :: (String -> a) -> String -> SDoc -> a
-pprAndThen cont heading pretty_msg =
-  cont (show (runSDoc doc (initSDocContext PprDebug)))
- where
-     doc = sep [text heading, nest 4 pretty_msg]
-
-assertPprPanic :: String -> Int -> SDoc -> a
--- ^ Panic with an assertation failure, recording the given file and line number.
--- Should typically be accessed with the ASSERT family of macros
-assertPprPanic file line msg
-  = panic (show (runSDoc doc (initSDocContext PprDebug)))
-  where
-    doc = sep [hsep[text "ASSERT failed! file",
-                           text file,
-                           text "line", int line],
-                    msg]
-
 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
 -- ^ Just warn about an assertion failure, recording the given file and line number.
 -- Should typically be accessed with the WARN macros
 warnPprTrace _     _file _line _msg x | opt_NoDebugOutput = x
 warnPprTrace False _file _line _msg x = x
 warnPprTrace True   file  line  msg x
-  = trace (show (runSDoc doc (initSDocContext defaultDumpStyle))) x
+  = pprDebugAndThen trace "WARNING:" doc x
   where
     doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
                msg]
+
+assertPprPanic :: String -> Int -> SDoc -> a
+-- ^ Panic with an assertation failure, recording the given file and line number.
+-- Should typically be accessed with the ASSERT family of macros
+assertPprPanic file line msg
+  = pprDebugAndThen panic "ASSERT failed!" doc
+  where
+    doc = sep [ hsep [ text "file", text file
+                     , text "line", int line ]
+              , msg ]
+
+pprDebugAndThen :: (String -> a) -> String -> SDoc -> a
+pprDebugAndThen cont heading pretty_msg 
+ = cont (show (runSDoc doc (initSDocContext PprDebug)))
+ where
+     doc = sep [text heading, nest 4 pretty_msg]
 \end{code}