diff options
| -rw-r--r-- | compiler/deSugar/Check.hs | 60 | ||||
| -rw-r--r-- | compiler/deSugar/DsMonad.hs | 6 | ||||
| -rw-r--r-- | compiler/hsSyn/HsExpr.hs | 4 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 4 | ||||
| -rw-r--r-- | docs/users_guide/debugging.rst | 5 |
5 files changed, 75 insertions, 4 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index 0a7706c203..b5f6eace89 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -142,6 +142,7 @@ type PmResult = ([Located [LPat Id]], Uncovered, [Located [LPat Id]]) -- | Check a single pattern binding (let) checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat Id -> DsM () checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do + tracePm "checkSingle" (vcat [ppr ctxt, ppr var, ppr p]) mb_pm_res <- tryM (checkSingle' locn var p) case mb_pm_res of Left _ -> warnPmIters dflags ctxt @@ -154,6 +155,7 @@ checkSingle' locn var p = do fam_insts <- dsGetFamInstEnvs clause <- translatePat fam_insts p missing <- mkInitialUncovered [var] + tracePm "checkSingle: missing" (vcat (map pprValVecDebug missing)) (cs,us,ds) <- runMany (pmcheckI clause []) missing -- no guards return $ case (cs,ds) of (True, _ ) -> ([], us, []) -- useful @@ -165,6 +167,11 @@ checkSingle' locn var p = do checkMatches :: DynFlags -> DsMatchContext -> [Id] -> [LMatch Id (LHsExpr Id)] -> DsM () checkMatches dflags ctxt vars matches = do + tracePm "checkMatches" (hang (vcat [ppr ctxt + , ppr vars + , text "Matches:"]) + 2 + (vcat (map ppr matches))) mb_pm_res <- tryM (checkMatches' vars matches) case mb_pm_res of Left _ -> warnPmIters dflags ctxt @@ -177,11 +184,13 @@ checkMatches' vars matches | otherwise = do resetPmIterDs -- set the iter-no to zero missing <- mkInitialUncovered vars + tracePm "checkMatches: missing" (vcat (map pprValVecDebug missing)) (rs,us,ds) <- go matches missing return (map hsLMatchToLPats rs, us, map hsLMatchToLPats ds) where go [] missing = return ([], missing, []) go (m:ms) missing = do + tracePm "checMatches': go" (ppr m $$ ppr missing) fam_insts <- dsGetFamInstEnvs (clause, guards) <- translateMatch fam_insts m (cs, missing', ds) <- runMany (pmcheckI clause guards) missing @@ -900,7 +909,12 @@ mkInitialUncovered vars = do -- | Increase the counter for elapsed algorithm iterations, check that the -- limit is not exceeded and call `pmcheck` pmcheckI :: PatVec -> [PatVec] -> ValVec -> PmM Triple -pmcheckI ps guards vva = incrCheckPmIterDs >> pmcheck ps guards vva +pmcheckI ps guards vva = do + n <- incrCheckPmIterDs + tracePm "pmCheck" (ppr n <> colon <+> pprPatVec ps + $$ hang (text "guards:") 2 (vcat (map pprPatVec guards)) + $$ pprValVecDebug vva) + pmcheck ps guards vva {-# INLINE pmcheckI #-} -- | Increase the counter for elapsed algorithm iterations, check that the @@ -912,8 +926,15 @@ pmcheckGuardsI gvs vva = incrCheckPmIterDs >> pmcheckGuards gvs vva -- | Increase the counter for elapsed algorithm iterations, check that the -- limit is not exceeded and call `pmcheckHd` pmcheckHdI :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec -> PmM Triple -pmcheckHdI p ps guards va vva = incrCheckPmIterDs >> - pmcheckHd p ps guards va vva +pmcheckHdI p ps guards va vva = do + n <- incrCheckPmIterDs + tracePm "pmCheckHdI" (ppr n <> colon <+> pprPmPatDebug p + $$ pprPatVec ps + $$ hang (text "guards:") 2 (vcat (map pprPatVec guards)) + $$ pprPmPatDebug va + $$ pprValVecDebug vva) + + pmcheckHd p ps guards va vva {-# INLINE pmcheckHdI #-} -- | Matching function: Check simultaneously a clause (takes separately the @@ -1416,3 +1437,36 @@ If instead we allow constraints of the form (e ~ e), The performance improvement becomes even more important when more arguments are involved. -} + +-- Debugging Infrastructre + +tracePm :: String -> SDoc -> PmM () +tracePm herald doc = do + dflags <- getDynFlags + printer <- mkPrintUnqualifiedDs + liftIO $ dumpIfSet_dyn_printer printer dflags + Opt_D_dump_ec_trace (text herald $$ (nest 2 doc)) + + +pprPmPatDebug :: PmPat a -> SDoc +pprPmPatDebug (PmCon cc _arg_tys _con_tvs _con_dicts con_args) + = hsep [text "PmCon", ppr cc, hsep (map pprPmPatDebug con_args)] +pprPmPatDebug (PmVar vid) = text "PmVar" <+> ppr vid +pprPmPatDebug (PmLit li) = text "PmLit" <+> ppr li +pprPmPatDebug (PmNLit i nl) = text "PmNLit" <+> ppr i <+> ppr nl +pprPmPatDebug (PmGrd pv ge) = text "PmGrd" <+> hsep (map pprPmPatDebug pv) + <+> ppr ge + +pprPatVec :: PatVec -> SDoc +pprPatVec ps = hang (text "Pattern:") 2 + (brackets $ sep + $ punctuate (comma <> char '\n') (map pprPmPatDebug ps)) + +pprValAbs :: [ValAbs] -> SDoc +pprValAbs ps = hang (text "ValAbs:") 2 + (brackets $ sep + $ punctuate (comma) (map pprPmPatDebug ps)) + +pprValVecDebug :: ValVec -> SDoc +pprValVecDebug (ValVec vas _d) = text "ValVec" <+> + parens (pprValAbs vas) diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs index 6713aa9663..d46aeaab7a 100644 --- a/compiler/deSugar/DsMonad.hs +++ b/compiler/deSugar/DsMonad.hs @@ -90,6 +90,9 @@ data DsMatchContext = DsMatchContext (HsMatchContext Name) SrcSpan deriving () +instance Outputable DsMatchContext where + ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match + data EquationInfo = EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn eqn_rhs :: MatchResult } -- What to do after match @@ -359,7 +362,7 @@ addTmCsDs tm_cs -- | Increase the counter for elapsed pattern match check iterations. -- If the current counter is already over the limit, fail -incrCheckPmIterDs :: DsM () +incrCheckPmIterDs :: DsM Int incrCheckPmIterDs = do env <- getLclEnv cnt <- readTcRef (dsl_pm_iter env) @@ -367,6 +370,7 @@ incrCheckPmIterDs = do if cnt >= max_iters then failM else updTcRef (dsl_pm_iter env) (+1) + return cnt -- | Reset the counter for pattern match check iterations to zero resetPmIterDs :: DsM () diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index fdce60a172..df60084a50 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -1347,6 +1347,10 @@ data Match id body } deriving instance (Data body,DataId id) => Data (Match id body) +instance (OutputableBndrId idR, Outputable body) + => Outputable (Match idR body) where + ppr = pprMatch + {- Note [m_ctxt in Match] ~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index ffebf3b29b..fba188bcea 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -355,6 +355,7 @@ data DumpFlag | Opt_D_dump_simpl_stats | Opt_D_dump_cs_trace -- Constraint solver in type checker | Opt_D_dump_tc_trace + | Opt_D_dump_ec_trace -- Pattern match exhaustiveness checker | Opt_D_dump_if_trace | Opt_D_dump_vt_trace | Opt_D_dump_splices @@ -1808,6 +1809,7 @@ dopt f dflags = (fromEnum f `IntSet.member` dumpFlags dflags) enableIfVerbose Opt_D_dump_view_pattern_commoning = False enableIfVerbose Opt_D_dump_mod_cycles = False enableIfVerbose Opt_D_dump_mod_map = False + enableIfVerbose Opt_D_dump_ec_trace = False enableIfVerbose _ = True -- | Set a 'DumpFlag' @@ -2760,6 +2762,8 @@ dynamic_flags_deps = [ , make_ord_flag defGhcFlag "ddump-tc-trace" (NoArg (do setDumpFlag' Opt_D_dump_tc_trace setDumpFlag' Opt_D_dump_cs_trace)) + , make_ord_flag defGhcFlag "ddump-ec-trace" + (setDumpFlag Opt_D_dump_ec_trace) , make_ord_flag defGhcFlag "ddump-vt-trace" (setDumpFlag Opt_D_dump_vt_trace) , make_ord_flag defGhcFlag "ddump-splices" diff --git a/docs/users_guide/debugging.rst b/docs/users_guide/debugging.rst index d414408a02..ba44e60074 100644 --- a/docs/users_guide/debugging.rst +++ b/docs/users_guide/debugging.rst @@ -193,6 +193,11 @@ Dumping out compiler intermediate structures Make the renamer be *real* chatty about what it is up to. +.. ghc-flag:: -ddump-ec-trace + + Make the pattern match exhaustiveness checker be *real* chatty about + what it is up to. + .. ghc-flag:: -ddump-rn-stats Print out summary of what kind of information the renamer had to |