[commit: ghc] master: Typechecker debug tracing only (e840d85)
git at git.haskell.org
git at git.haskell.org
Tue Nov 4 10:38:24 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/e840d85309ba1de954dad6ad3acfdddafc5d5ac6/ghc
>---------------------------------------------------------------
commit e840d85309ba1de954dad6ad3acfdddafc5d5ac6
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Wed Oct 29 17:22:57 2014 +0000
Typechecker debug tracing only
>---------------------------------------------------------------
e840d85309ba1de954dad6ad3acfdddafc5d5ac6
compiler/typecheck/TcErrors.lhs | 1 +
compiler/typecheck/TcHsType.lhs | 9 ++++---
compiler/typecheck/TcRnDriver.lhs | 2 +-
compiler/typecheck/TcRnMonad.lhs | 57 ++++++++++++++++++++-------------------
4 files changed, 38 insertions(+), 31 deletions(-)
diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index 210bd79..72fe9fa 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -606,6 +606,7 @@ mkEqErr1 ctxt ct
; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc)
; let (is_oriented, wanted_msg) = mk_wanted_extra tidy_orig
; dflags <- getDynFlags
+ ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctLocOrigin loc) $$ pprCtOrigin tidy_orig)
; mkEqErr_help dflags (ctxt {cec_tidy = env1})
(wanted_msg $$ binds_msg)
ct is_oriented ty1 ty2 }
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index c9f0e2f..d6f237f 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -425,9 +425,11 @@ tc_hs_type hs_ty@(HsPArrTy elt_ty) exp_kind
tc_hs_type hs_ty@(HsTupleTy HsBoxedOrConstraintTuple hs_tys) exp_kind@(EK exp_k _ctxt)
-- (NB: not zonking before looking at exp_k, to avoid left-right bias)
| Just tup_sort <- tupKindSort_maybe exp_k
- = tc_tuple hs_ty tup_sort hs_tys exp_kind
+ = traceTc "tc_hs_type tuple" (ppr hs_tys) >>
+ tc_tuple hs_ty tup_sort hs_tys exp_kind
| otherwise
- = do { (tys, kinds) <- mapAndUnzipM tc_infer_lhs_type hs_tys
+ = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys)
+ ; (tys, kinds) <- mapAndUnzipM tc_infer_lhs_type hs_tys
; kinds <- mapM zonkTcKind kinds
-- Infer each arg type separately, because errors can be
-- confusing if we give them a shared kind. Eg Trac #7410
@@ -554,7 +556,8 @@ tc_tuple hs_ty tup_sort tys exp_kind
finish_tuple :: HsType Name -> TupleSort -> [TcType] -> ExpKind -> TcM TcType
finish_tuple hs_ty tup_sort tau_tys exp_kind
- = do { checkExpectedKind hs_ty res_kind exp_kind
+ = do { traceTc "finish_tuple" (ppr res_kind $$ ppr exp_kind $$ ppr exp_kind)
+ ; checkExpectedKind hs_ty res_kind exp_kind
; checkWiredInTyCon tycon
; return (mkTyConApp tycon tau_tys) }
where
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index e6f7824..9ac01ed 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -1916,7 +1916,7 @@ tcDump env
-- Dump short output if -ddump-types or -ddump-tc
when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
- (dumpTcRn short_dump) ;
+ (printForUserTcRn short_dump) ;
-- Dump bindings if -ddump-tc
dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index bd6218c..dce4b49 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -192,8 +192,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
lie <- readIORef lie_var ;
if isEmptyWC lie
then return ()
- else pprPanic "initTc: unsolved constraints"
- (pprWantedsWithLocs lie) ;
+ else pprPanic "initTc: unsolved constraints" (ppr lie) ;
-- Collect any error messages
msgs <- readIORef errs_var ;
@@ -487,25 +486,35 @@ traceIf = traceOptIf Opt_D_dump_if_trace
traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
-traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n () -- No RdrEnv available, so qualify everything
-traceOptIf flag doc = whenDOptM flag $
- do dflags <- getDynFlags
- liftIO (printInfoForUser dflags alwaysQualify doc)
+traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n ()
+traceOptIf flag doc
+ = whenDOptM flag $ -- No RdrEnv available, so qualify everything
+ do { dflags <- getDynFlags
+ ; liftIO (putMsg dflags doc) }
traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
-- Output the message, with current location if opt_PprStyle_Debug
-traceOptTcRn flag doc = whenDOptM flag $ do
- { loc <- getSrcSpanM
- ; let real_doc
- | opt_PprStyle_Debug = mkLocMessage SevInfo loc doc
- | otherwise = doc -- The full location is
- -- usually way too much
- ; dumpTcRn real_doc }
+traceOptTcRn flag doc
+ = whenDOptM flag $
+ do { loc <- getSrcSpanM
+ ; let real_doc
+ | opt_PprStyle_Debug = mkLocMessage SevInfo loc doc
+ | otherwise = doc -- The full location is
+ -- usually way too much
+ ; dumpTcRn real_doc }
dumpTcRn :: SDoc -> TcRn ()
-dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv
- ; dflags <- getDynFlags
- ; liftIO (printInfoForUser dflags (mkPrintUnqualified dflags rdr_env) doc) }
+dumpTcRn doc
+ = do { dflags <- getDynFlags
+ ; rdr_env <- getGlobalRdrEnv
+ ; liftIO (logInfo dflags (mkDumpStyle (mkPrintUnqualified dflags rdr_env)) doc) }
+
+printForUserTcRn :: SDoc -> TcRn ()
+-- Like dumpTcRn, but for user consumption
+printForUserTcRn doc
+ = do { dflags <- getDynFlags
+ ; rdr_env <- getGlobalRdrEnv
+ ; liftIO (printInfoForUser dflags (mkPrintUnqualified dflags rdr_env) doc) }
debugDumpTcRn :: SDoc -> TcRn ()
debugDumpTcRn doc | opt_NoDebugOutput = return ()
@@ -698,14 +707,6 @@ reportWarning warn
errs_var <- getErrsVar ;
(warns, errs) <- readTcRef errs_var ;
writeTcRef errs_var (warns `snocBag` warn, errs) }
-
-dumpDerivingInfo :: SDoc -> TcM ()
-dumpDerivingInfo doc
- = do { dflags <- getDynFlags
- ; when (dopt Opt_D_dump_deriv dflags) $ do
- { rdr_env <- getGlobalRdrEnv
- ; let unqual = mkPrintUnqualified dflags rdr_env
- ; liftIO (putMsgWith dflags unqual doc) } }
\end{code}
@@ -1052,9 +1053,11 @@ newTcEvBinds = do { ref <- newTcRef emptyEvBindMap
addTcEvBind :: EvBindsVar -> EvVar -> EvTerm -> TcM ()
-- Add a binding to the TcEvBinds by side effect
-addTcEvBind (EvBindsVar ev_ref _) var t
- = do { bnds <- readTcRef ev_ref
- ; writeTcRef ev_ref (extendEvBinds bnds var t) }
+addTcEvBind (EvBindsVar ev_ref _) ev_id ev_tm
+ = do { traceTc "addTcEvBind" $ vcat [ text "ev_id =" <+> ppr ev_id
+ , text "ev_tm =" <+> ppr ev_tm ]
+ ; bnds <- readTcRef ev_ref
+ ; writeTcRef ev_ref (extendEvBinds bnds ev_id ev_tm) }
getTcEvBinds :: EvBindsVar -> TcM (Bag EvBind)
getTcEvBinds (EvBindsVar ev_ref _)
More information about the ghc-commits
mailing list