[commit: ghc] master: Improve tracing in TcInteract (7212968)

[git at git.haskell.org]

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

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

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

commit 72129686a319406e0c317619d1ba521a7f5b25f3
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Mon Feb 8 13:18:35 2016 +0000

    Improve tracing in TcInteract


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

72129686a319406e0c317619d1ba521a7f5b25f3
 compiler/typecheck/TcInteract.hs | 17 ++++++++++-------
 compiler/typecheck/TcSMonad.hs   | 11 +++++++++--
 2 files changed, 19 insertions(+), 9 deletions(-)

diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
index 86cc8b3..b7a96d9 100644
--- a/compiler/typecheck/TcInteract.hs
+++ b/compiler/typecheck/TcInteract.hs
@@ -137,8 +137,11 @@ solveSimpleGivens givens
   | null givens  -- Shortcut for common case
   = return emptyCts
   | otherwise
-  = do { go givens
-       ; takeGivenInsolubles }
+  = do { traceTcS "solveSimpleGivens {" (ppr givens)
+       ; go givens
+       ; given_insols <- takeGivenInsolubles
+       ; traceTcS "End solveSimpleGivens }" (text "Insoluble:" <+> pprCts given_insols)
+       ; return given_insols }
   where
     go givens = do { solveSimples (listToBag givens)
                    ; new_givens <- runTcPluginsGiven
@@ -149,10 +152,10 @@ solveSimpleWanteds :: Cts -> TcS WantedConstraints
 -- NB: 'simples' may contain /derived/ equalities, floated
 --     out from a nested implication. So don't discard deriveds!
 solveSimpleWanteds simples
-  = do { traceTcS "solveSimples {" (ppr simples)
+  = do { traceTcS "solveSimpleWanteds {" (ppr simples)
        ; dflags <- getDynFlags
        ; (n,wc) <- go 1 (solverIterations dflags) (emptyWC { wc_simple = simples })
-       ; traceTcS "solveSimples end }" $
+       ; traceTcS "solveSimpleWanteds end }" $
              vcat [ text "iterations =" <+> ppr n
                   , text "residual =" <+> ppr wc ]
        ; return wc }
@@ -375,10 +378,10 @@ runSolverPipeline :: [(String,SimplifierStage)] -- The pipeline
                   -> TcS ()
 -- Run this item down the pipeline, leaving behind new work and inerts
 runSolverPipeline pipeline workItem
-  = do { initial_is <- getTcSInerts
+  = do { wl <- getWorkList
        ; traceTcS "Start solver pipeline {" $
-                  vcat [ text "work item = " <+> ppr workItem
-                       , text "inerts    = " <+> ppr initial_is]
+                  vcat [ text "work item =" <+> ppr workItem
+                       , text "rest of worklist =" <+> ppr wl ]
 
        ; bumpStepCountTcS    -- One step for each constraint processed
        ; final_res  <- run_pipeline pipeline (ContinueWith workItem)
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index a6cf019..5f7abdd 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -10,7 +10,7 @@ module TcSMonad (
     appendWorkList,
     selectNextWorkItem,
     workListSize, workListWantedCount,
-    updWorkListTcS,
+    getWorkList, updWorkListTcS,
 
     -- The TcS monad
     TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds,
@@ -150,6 +150,7 @@ import Unique
 import UniqFM
 import Maybes
 
+import StaticFlags( opt_PprStyle_Debug )
 import TrieMap
 import Control.Monad
 #if __GLASGOW_HASKELL__ > 710
@@ -283,6 +284,10 @@ selectWorkItem wl@(WL { wl_eqs = eqs, wl_funeqs = feqs
   | ct:cts <- rest = Just (ct, wl { wl_rest   = cts })
   | otherwise      = Nothing
 
+getWorkList :: TcS WorkList
+getWorkList = do { wl_var <- getTcSWorkListRef
+                 ; wrapTcS (TcM.readTcRef wl_var) }
+
 selectDerivedWorkItem  :: WorkList -> Maybe (Ct, WorkList)
 selectDerivedWorkItem wl@(WL { wl_deriv = ders })
   | ev:evs <- ders = Just (mkNonCanonical ev, wl { wl_deriv  = evs })
@@ -324,7 +329,9 @@ instance Outputable WorkList where
           , ppUnless (null ders) $
             text "Derived =" <+> vcat (map ppr ders)
           , ppUnless (isEmptyBag implics) $
-            text "Implics =" <+> vcat (map ppr (bagToList implics))
+            if opt_PprStyle_Debug  -- Typically we only want the work list for this level
+            then text "Implics =" <+> vcat (map ppr (bagToList implics))
+            else text "(Implics omitted)"
           ])