Improved debug printing with -dverbose-core2core
authorSimon Peyton Jones <simonpj@microsoft.com>
Sun, 4 Mar 2012 08:08:46 +0000 (08:08 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Sun, 4 Mar 2012 08:14:28 +0000 (08:14 +0000)
(Roman wanted this.)

compiler/coreSyn/CoreUnfold.lhs
compiler/simplCore/CoreMonad.lhs
compiler/simplCore/Simplify.lhs
compiler/specialise/Specialise.lhs
compiler/utils/Outputable.lhs

index 930041d..96a1abd 100644 (file)
@@ -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,
index 829c2ca..4af626d 100644 (file)
@@ -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}
 
index ee20a52..b8c8160 100644 (file)
@@ -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
index 14235f4..321deb8 100644 (file)
@@ -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]
index b713896..b96ae5e 100644 (file)
@@ -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}