Commit 72129686 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Improve tracing in TcInteract

parent e72665b5
......@@ -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)
......
......@@ -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)"
])
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment