[commit: ghc] wip/new-flatten-skolems-Oct14: Typechecker debug tracing only (ac31ee3)

git at git.haskell.org git at git.haskell.org
Fri Oct 31 13:43:22 UTC 2014


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

On branch  : wip/new-flatten-skolems-Oct14
Link       : http://ghc.haskell.org/trac/ghc/changeset/ac31ee34be3d93f4220625195aa67d25bac19b7a/ghc

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

commit ac31ee34be3d93f4220625195aa67d25bac19b7a
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Wed Oct 29 17:22:57 2014 +0000

    Typechecker debug tracing only


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

ac31ee34be3d93f4220625195aa67d25bac19b7a
 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 e9a6f82..3440b4f 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -1920,7 +1920,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