Make traceRn behave more like traceTc
authorMatthew Pickering <matthewtpickering@gmail.com>
Wed, 26 Oct 2016 15:18:39 +0000 (11:18 -0400)
committerBen Gamari <ben@smart-cactus.org>
Wed, 26 Oct 2016 15:18:44 +0000 (11:18 -0400)
Reviewers: bgamari, austin

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2586

GHC Trac Issues: #12617

compiler/rename/RnEnv.hs
compiler/rename/RnExpr.hs
compiler/rename/RnNames.hs
compiler/rename/RnSource.hs
compiler/rename/RnSplice.hs
compiler/rename/RnTypes.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcRnExports.hs
compiler/typecheck/TcRnMonad.hs
testsuite/tests/perf/compiler/all.T

index f924f00..b5f2463 100644 (file)
@@ -215,7 +215,7 @@ newTopSrcBinder (L loc rdr_name)
                 ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }
           else
              do { this_mod <- getModule
-                ; traceRn (text "newTopSrcBinder" <+> (ppr this_mod $$ ppr rdr_name $$ ppr loc))
+                ; traceRn "newTopSrcBinder" (ppr this_mod $$ ppr rdr_name $$ ppr loc)
                 ; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc }
         }
 
@@ -245,7 +245,7 @@ lookupTopBndrRn :: RdrName -> RnM Name
 lookupTopBndrRn n = do nopt <- lookupTopBndrRn_maybe n
                        case nopt of
                          Just n' -> return n'
-                         Nothing -> do traceRn $ (text "lookupTopBndrRn fail" <+> ppr n)
+                         Nothing -> do traceRn "lookupTopBndrRn fail" (ppr n)
                                        unboundName WL_LocalTop n
 
 lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name)
@@ -497,7 +497,9 @@ lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name
                 -- NB: lookupGlobalRdrEnv, not lookupGRE_RdrName!
                 --     The latter does pickGREs, but we want to allow 'x'
                 --     even if only 'M.x' is in scope
-       ; traceRn (text "lookupSubBndrOcc" <+> vcat [ppr the_parent, ppr rdr_name, ppr gres, ppr (pick_gres rdr_name gres)])
+       ; traceRn "lookupSubBndrOcc"
+            (vcat [ ppr the_parent, ppr rdr_name
+                  , ppr gres, ppr (pick_gres rdr_name gres)])
        ; case pick_gres rdr_name gres of
             (gre:_) -> do { addUsedGRE warn_if_deprec gre
                             -- Add a usage; this is an *occurrence* site
@@ -832,7 +834,7 @@ lookupGlobalOccRn rdr_name
   = do { mb_name <- lookupGlobalOccRn_maybe rdr_name
        ; case mb_name of
            Just n  -> return n
-           Nothing -> do { traceRn (text "lookupGlobalOccRn" <+> ppr rdr_name)
+           Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name)
                          ; unboundName WL_Global rdr_name } }
 
 lookupInfoOccRn :: RdrName -> RnM [Name]
@@ -933,7 +935,8 @@ lookupGreRn_maybe rdr_name
             [gre] -> do { addUsedGRE True gre
                         ; return (Just gre) }
             gres  -> do { addNameClashErrRn rdr_name gres
-                        ; traceRn (text "name clash" <+> (ppr rdr_name $$ ppr gres $$ ppr env))
+                        ; traceRn "lookupGreRn:name clash"
+                            (ppr rdr_name $$ ppr gres $$ ppr env)
                         ; return (Just (head gres)) } }
 
 lookupGreRn2_maybe :: RdrName -> RnM (Maybe GlobalRdrElt)
@@ -950,7 +953,8 @@ lookupGreRn2_maybe rdr_name
             [gre] -> do { addUsedGRE True gre
                         ; return (Just gre) }
             gres  -> do { addNameClashErrRn rdr_name gres
-                        ; traceRn (text "name clash" <+> (ppr rdr_name $$ ppr gres $$ ppr env))
+                        ; traceRn "lookupGreRn_maybe:name clash"
+                            (ppr rdr_name $$ ppr gres $$ ppr env)
                         ; return Nothing } }
 
 lookupGreAvailRn :: RdrName -> RnM (Name, AvailInfo)
@@ -962,7 +966,7 @@ lookupGreAvailRn rdr_name
         ; case mb_gre of {
             Just gre -> return (gre_name gre, availFromGRE gre) ;
             Nothing  ->
-    do  { traceRn (text "lookupGreRn" <+> ppr rdr_name)
+    do  { traceRn "lookupGreAvailRn" (ppr rdr_name)
         ; let name = mkUnboundNameRdr rdr_name
         ; return (name, avail name) } } }
 
@@ -1004,7 +1008,7 @@ addUsedGRE warn_if_deprec gre
   = do { when warn_if_deprec (warnIfDeprecated gre)
        ; unless (isLocalGRE gre) $
          do { env <- getGblEnv
-            ; traceRn (text "addUsedGRE" <+> ppr gre)
+            ; traceRn "addUsedGRE" (ppr gre)
             ; updMutVar (tcg_used_gres env) (gre :) } }
 
 addUsedGREs :: [GlobalRdrElt] -> RnM ()
@@ -1014,7 +1018,7 @@ addUsedGREs :: [GlobalRdrElt] -> RnM ()
 addUsedGREs gres
   | null imp_gres = return ()
   | otherwise     = do { env <- getGblEnv
-                       ; traceRn (text "addUsedGREs" <+> ppr imp_gres)
+                       ; traceRn "addUsedGREs" (ppr imp_gres)
                        ; updMutVar (tcg_used_gres env) (imp_gres ++) }
   where
     imp_gres = filterOut isLocalGRE gres
@@ -1126,11 +1130,11 @@ lookupQualifiedNameGHCi rdr_name
 
                 _ -> -- Either we couldn't load the interface, or
                      -- we could but we didn't find the name in it
-                     do { traceRn (text "lookupQualifiedNameGHCi" <+> ppr rdr_name)
+                     do { traceRn "lookupQualifiedNameGHCi" (ppr rdr_name)
                         ; return [] } }
 
       | otherwise
-      = do { traceRn (text "lookupQualifedNameGHCi: off" <+> ppr rdr_name)
+      = do { traceRn "lookupQualifedNameGHCi: off" (ppr rdr_name)
            ; return [] }
 
     doc = text "Need to find" <+> ppr rdr_name
@@ -1455,7 +1459,7 @@ lookupFixityRn_help' name occ
                             Just f ->
                                   text "looking up name in iface and found:"
                               <+> vcat [ppr name, ppr f]
-           ; traceRn (text "lookupFixityRn_either:" <+> msg)
+           ; traceRn "lookupFixityRn_either:" msg
            ; return (maybe (False, defaultFixity) (\f -> (True, f)) mb_fix)  }
 
     doc = text "Checking fixity for" <+> ppr name
@@ -1476,7 +1480,7 @@ lookupFieldFixityRn (Ambiguous   (L _ rdr) _) = get_ambiguous_fixity rdr
   where
     get_ambiguous_fixity :: RdrName -> RnM Fixity
     get_ambiguous_fixity rdr_name = do
-      traceRn $ text "get_ambiguous_fixity" <+> ppr rdr_name
+      traceRn "get_ambiguous_fixity" (ppr rdr_name)
       rdr_env <- getGlobalRdrEnv
       let elts =  lookupGRE_RdrName rdr_name rdr_env
 
@@ -1729,7 +1733,7 @@ checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv)
                   -> [a] -> RnM ()
 checkShadowedOccs (global_env,local_env) get_loc_occ ns
   = whenWOptM Opt_WarnNameShadowing $
-    do  { traceRn (text "shadow" <+> ppr (map get_loc_occ ns))
+    do  { traceRn "checkShadowedOccs:shadow" (ppr (map get_loc_occ ns))
         ; mapM_ check_shadow ns }
   where
     check_shadow n
index 7a0f2c8..991162d 100644 (file)
@@ -888,7 +888,7 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for
              bndr_map = used_bndrs `zip` used_bndrs
              -- See Note [TransStmt binder map] in HsExpr
 
-       ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
+       ; traceRn "rnStmt: implicitly rebound these used binders:" (ppr bndr_map)
        ; return (([(L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map
                                     , trS_by = by', trS_using = using', trS_form = form
                                     , trS_ret = return_op, trS_bind = bind_op
index bdc9dcb..549bccb 100644 (file)
@@ -494,7 +494,7 @@ extendGlobalRdrEnvRn avails new_fixities
         ; let fix_env' = foldl extend_fix_env fix_env new_gres
               gbl_env' = gbl_env { tcg_rdr_env = rdr_env2, tcg_fix_env = fix_env' }
 
-        ; traceRn (text "extendGlobalRdrEnvRn 2" <+> (pprGlobalRdrEnv True rdr_env2))
+        ; traceRn "extendGlobalRdrEnvRn 2" (pprGlobalRdrEnv True rdr_env2)
         ; return (gbl_env', lcl_env3) }
   where
     new_names = concatMap availNames avails
@@ -560,7 +560,7 @@ getLocalNonValBinders fixity_env
         ; (tc_avails, tc_fldss)
             <- fmap unzip $ mapM (new_tc overload_ok)
                                  (tyClGroupTyClDecls tycl_decls)
-        ; traceRn (text "getLocalNonValBinders 1" <+> ppr tc_avails)
+        ; traceRn "getLocalNonValBinders 1" (ppr tc_avails)
         ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env
         ; setEnvs envs $ do {
             -- Bring these things into scope first
@@ -583,7 +583,7 @@ getLocalNonValBinders fixity_env
               new_bndrs = availsToNameSetWithSelectors avails `unionNameSet`
                           availsToNameSetWithSelectors tc_avails
               flds      = concat nti_fldss ++ concat tc_fldss
-        ; traceRn (text "getLocalNonValBinders 2" <+> ppr avails)
+        ; traceRn "getLocalNonValBinders 2" (ppr avails)
         ; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn avails fixity_env
 
         -- Extend tcg_field_env with new fields (this used to be the
@@ -591,7 +591,7 @@ getLocalNonValBinders fixity_env
         ; let field_env = extendNameEnvList (tcg_field_env tcg_env) flds
               envs      = (tcg_env { tcg_field_env = field_env }, tcl_env)
 
-        ; traceRn (text "getLocalNonValBinders 3" <+> vcat [ppr flds, ppr field_env])
+        ; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env])
         ; return (envs, new_bndrs) } }
   where
     ValBindsIn _val_binds val_sigs = binds
@@ -1067,7 +1067,7 @@ lookupChildren all_kids rdr_items
 reportUnusedNames :: Maybe (Located [LIE RdrName])  -- Export list
                   -> TcGblEnv -> RnM ()
 reportUnusedNames _export_decls gbl_env
-  = do  { traceRn ((text "RUN") <+> (ppr (tcg_dus gbl_env)))
+  = do  { traceRn "RUN" (ppr (tcg_dus gbl_env))
         ; warnUnusedImportDecls gbl_env
         ; warnUnusedTopBinds unused_locals
         ; warnMissingSignatures gbl_env }
@@ -1137,7 +1137,8 @@ warnUnusedImportDecls gbl_env
        ; let usage :: [ImportDeclUsage]
              usage = findImportUsage user_imports uses
 
-       ; traceRn (vcat [ text "Uses:" <+> ppr uses
+       ; traceRn "warnUnusedImportDecls" $
+                       (vcat [ text "Uses:" <+> ppr uses
                        , text "Import usage" <+> ppr usage])
        ; whenWOptM Opt_WarnUnusedImports $
          mapM_ (warnUnusedImport Opt_WarnUnusedImports fld_env) usage
index 2c493d6..c71abfa 100644 (file)
@@ -132,9 +132,9 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
    -- Bind the LHSes (and their fixities) in the global rdr environment
    let { id_bndrs = collectHsIdBinders new_lhs } ;  -- Excludes pattern-synonym binders
                                                     -- They are already in scope
-   traceRn (text "rnSrcDecls" <+> ppr id_bndrs) ;
+   traceRn "rnSrcDecls" (ppr id_bndrs) ;
    tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ;
-   traceRn (text "D2" <+> ppr (tcg_rdr_env (fst tc_envs)));
+   traceRn "D2" (ppr (tcg_rdr_env (fst tc_envs)));
    setEnvs tc_envs $ do {
 
    --  Now everything is in scope, as the remaining renaming assumes.
@@ -149,11 +149,11 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
    -- So we content ourselves with gathering uses only; that
    -- means we'll only report a declaration as unused if it isn't
    -- mentioned at all.  Ah well.
-   traceRn (text "Start rnTyClDecls" <+> ppr tycl_decls) ;
+   traceRn "Start rnTyClDecls" (ppr tycl_decls) ;
    (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;
 
    -- (F) Rename Value declarations right-hand sides
-   traceRn (text "Start rnmono") ;
+   traceRn "Start rnmono" empty ;
    let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ;
    is_boot <- tcIsHsBootOrSig ;
    (rn_val_decls, bind_dus) <- if is_boot
@@ -162,7 +162,7 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
     -- bindings in an hs-boot.)
     then rnTopBindsBoot tc_bndrs new_lhs
     else rnValBindsRHS (TopSigCtxt val_bndr_set) new_lhs ;
-   traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
+   traceRn "finish rnmono" (ppr rn_val_decls) ;
 
    -- (G) Rename Fixity and deprecations
 
@@ -220,9 +220,9 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
                         in -- we return the deprecs in the env, not in the HsGroup above
                         tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
        } ;
-   traceRn (text "last" <+> ppr (tcg_rdr_env final_tcg_env)) ;
-   traceRn (text "finish rnSrc" <+> ppr rn_group) ;
-   traceRn (text "finish Dus" <+> ppr src_dus ) ;
+   traceRn "last" (ppr (tcg_rdr_env final_tcg_env)) ;
+   traceRn "finish rnSrc" (ppr rn_group) ;
+   traceRn "finish Dus" (ppr src_dus ) ;
    return (final_tcg_env, rn_group)
                     }}}}
 
@@ -682,7 +682,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
 
        -- Rename the associated types, and type signatures
        -- Both need to have the instance type variables in scope
-       ; traceRn (text "rnSrcInstDecl"  <+> ppr inst_ty' $$ ppr ktv_names)
+       ; traceRn "rnSrcInstDecl" (ppr inst_ty' $$ ppr ktv_names)
        ; ((ats', adts'), more_fvs)
              <- extendTyVarEnvFVRn ktv_names $
                 do { (ats',  at_fvs)  <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats
@@ -1319,7 +1319,7 @@ rnTyClDecls tycl_ds
                                        $$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds  )
          mapM_ orphanRoleAnnotErr (nameEnvElts orphan_roles)
 
-       ; traceRn (text "rnTycl dependency analysis made groups" $$ ppr all_groups)
+       ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups)
        ; return (all_groups, all_fvs) }
   where
     mk_group :: (InstDeclFreeVarsMap, RoleAnnotEnv)
@@ -1636,7 +1636,7 @@ rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdRhs = rhs })
   = do { tycon' <- lookupLocatedTopBndrRn tycon
        ; kvs <- freeKiTyVarsKindVars <$> extractHsTyRdrTyVars rhs
        ; let doc = TySynCtx tycon
-       ; traceRn (text "rntycl-ty" <+> ppr tycon <+> ppr kvs)
+       ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs)
        ; ((tyvars', rhs'), fvs) <- bindHsQTyVars doc Nothing Nothing kvs tyvars $
                                     \ tyvars' _ ->
                                     do { (rhs', fvs) <- rnTySyn doc rhs
@@ -1650,7 +1650,7 @@ rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdDataDefn = defn
   = do { tycon' <- lookupLocatedTopBndrRn tycon
        ; kvs <- extractDataDefnKindVars defn
        ; let doc = TyDataCtx tycon
-       ; traceRn (text "rntycl-data" <+> ppr tycon <+> ppr kvs)
+       ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs)
        ; ((tyvars', defn', no_kvs), fvs)
            <- bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' dep_vars ->
               do { ((defn', kind_sig_fvs), fvs) <- rnDataDefn doc defn
@@ -2016,7 +2016,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs
                                              ; return (Just lctx',fvs) }
         ; (new_details, fvs2) <- rnConDeclDetails (unLoc new_name) doc details
         ; let (new_details',fvs3) = (new_details,emptyFVs)
-        ; traceRn (text "rnConDecl" <+> ppr name <+> vcat
+        ; traceRn "rnConDecl" (ppr name <+> vcat
              [ text "free_kvs:" <+> ppr kvs
              , text "qtvs:" <+> ppr qtvs
              , text "qtvs':" <+> ppr qtvs' ])
@@ -2049,7 +2049,7 @@ rnConDecl decl@(ConDeclGADT { con_names = names, con_type = ty
         ; mb_doc'      <- rnMbLHsDoc mb_doc
 
         ; (ty', fvs) <- rnHsSigType doc ty
-        ; traceRn (text "rnConDecl" <+> ppr names <+> vcat
+        ; traceRn "rnConDecl" (ppr names <+> vcat
              [ text "fvs:" <+> ppr fvs ])
         ; return (decl { con_names = new_names, con_type = ty'
                        , con_doc = mb_doc' },
index 557b9f8..57c3587 100644 (file)
@@ -99,13 +99,13 @@ rnBracket e br_body
        ; recordThUse
 
        ; case isTypedBracket br_body of
-            True  -> do { traceRn (text "Renaming typed TH bracket")
+            True  -> do { traceRn "Renaming typed TH bracket" empty
                         ; (body', fvs_e) <-
                           setStage (Brack cur_stage RnPendingTyped) $
                                    rn_bracket cur_stage br_body
                         ; return (HsBracket body', fvs_e) }
 
-            False -> do { traceRn (text "Renaming untyped TH bracket")
+            False -> do { traceRn "Renaming untyped TH bracket" empty
                         ; ps_var <- newMutVar []
                         ; (body', fvs_e) <-
                           setStage (Brack cur_stage (RnPendingUntyped ps_var)) $
@@ -130,7 +130,9 @@ rn_bracket outer_stage br@(VarBr flg rdr_name)
                              | isTopLevel top_lvl
                              -> when (isExternalName name) (keepAlive name)
                              | otherwise
-                             -> do { traceRn (text "rn_bracket VarBr" <+> ppr name <+> ppr bind_lvl <+> ppr outer_stage)
+                             -> do { traceRn "rn_bracket VarBr"
+                                      (ppr name <+> ppr bind_lvl
+                                                <+> ppr outer_stage)
                                    ; checkTc (thLevel outer_stage + 1 == bind_lvl)
                                              (quotedNameStageErr br) }
                         }
@@ -155,8 +157,8 @@ rn_bracket _ (DecBrL decls)
                               rnSrcDecls group
 
               -- Discard the tcg_env; it contains only extra info about fixity
-        ; traceRn (text "rn_bracket dec" <+> (ppr (tcg_dus tcg_env) $$
-                   ppr (duUses (tcg_dus tcg_env))))
+        ; traceRn "rn_bracket dec" (ppr (tcg_dus tcg_env) $$
+                   ppr (duUses (tcg_dus tcg_env)))
         ; return (DecBrG group', duUses (tcg_dus tcg_env)) }
   where
     groupDecls :: [LHsDecl RdrName] -> RnM (HsGroup RdrName)
@@ -420,7 +422,7 @@ rnSpliceExpr splice
     run_expr_splice rn_splice
       | isTypedSplice rn_splice   -- Run it later, in the type checker
       = do {  -- Ugh!  See Note [Splices] above
-             traceRn (text "rnSpliceExpr: typed expression splice")
+             traceRn "rnSpliceExpr: typed expression splice" empty
            ; lcl_rdr <- getLocalRdrEnv
            ; gbl_rdr <- getGlobalRdrEnv
            ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr
@@ -430,7 +432,7 @@ rnSpliceExpr splice
            ; return (HsSpliceE rn_splice, lcl_names `plusFV` gbl_names) }
 
       | otherwise  -- Run it here, see Note [Running splices in the Renamer]
-      = do { traceRn (text "rnSpliceExpr: untyped expression splice")
+      = do { traceRn "rnSpliceExpr: untyped expression splice" empty
            ; (rn_expr, mod_finalizers) <-
                 runRnSplice UntypedExpSplice runMetaE ppr rn_splice
            ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr)
@@ -542,7 +544,7 @@ rnSpliceType splice k
        = (makePending UntypedTypeSplice rn_splice, HsSpliceTy rn_splice k)
 
     run_type_splice rn_splice
-      = do { traceRn (text "rnSpliceType: untyped type splice")
+      = do { traceRn "rnSpliceType: untyped type splice" empty
            ; (hs_ty2, mod_finalizers) <-
                 runRnSplice UntypedTypeSplice runMetaT ppr rn_splice
            ; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2
@@ -609,7 +611,7 @@ rnSplicePat splice
       = (makePending UntypedPatSplice rn_splice, Right (SplicePat rn_splice))
 
     run_pat_splice rn_splice
-      = do { traceRn (text "rnSplicePat: untyped pattern splice")
+      = do { traceRn "rnSplicePat: untyped pattern splice" empty
            ; (pat, mod_finalizers) <-
                 runRnSplice UntypedPatSplice runMetaP ppr rn_splice
              -- See Note [Delaying modFinalizers in untyped splices].
@@ -640,7 +642,7 @@ rnTopSpliceDecls splice
                                rnSplice splice
            -- As always, be sure to checkNoErrs above lest we end up with
            -- holes making it to typechecking, hence #12584.
-         ; traceRn (text "rnTopSpliceDecls: untyped declaration splice")
+         ; traceRn "rnTopSpliceDecls: untyped declaration splice" empty
          ; (decls, mod_finalizers) <-
               runRnSplice UntypedDeclSplice runMetaD ppr_decls rn_splice
          ; add_mod_finalizers_now mod_finalizers
@@ -766,14 +768,16 @@ checkThLocalName name
   = return ()            --   $(not_in_scope args)
 
   | otherwise
-  = do  { traceRn (text "checkThLocalName" <+> ppr name)
+  = do  { traceRn "checkThLocalName" (ppr name)
         ; mb_local_use <- getStageAndBindLevel name
         ; case mb_local_use of {
              Nothing -> return () ;  -- Not a locally-bound thing
              Just (top_lvl, bind_lvl, use_stage) ->
     do  { let use_lvl = thLevel use_stage
         ; checkWellStaged (quotes (ppr name)) bind_lvl use_lvl
-        ; traceRn (text "checkThLocalName" <+> ppr name <+> ppr bind_lvl <+> ppr use_stage <+> ppr use_lvl)
+        ; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl
+                                               <+> ppr use_stage
+                                               <+> ppr use_lvl)
         ; checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name } } }
 
 --------------------------------------
@@ -817,7 +821,7 @@ check_cross_stage_lifting top_lvl name ps_var
         -- If 'x' occurs many times we may get many identical
         -- bindings of the same SplicePointName, but that doesn't
         -- matter, although it's a mite untidy.
-    do  { traceRn (text "checkCrossStageLifting" <+> ppr name)
+    do  { traceRn "checkCrossStageLifting" (ppr name)
 
           -- Construct the (lift x) expression
         ; let lift_expr   = nlHsApp (nlHsVar liftName) (nlHsVar name)
index d672aa0..870baad 100644 (file)
@@ -265,8 +265,8 @@ rnImplicitBndrs no_implicit_if_forall free_vars hs_ty@(L loc _) thing_inside
                , L _ (HsForAllTy {}) <- hs_ty = []
                | otherwise                    = freeKiTyVarsTypeVars free_vars
              real_rdrs = freeKiTyVarsKindVars free_vars ++ real_tv_rdrs
-       ; traceRn (text "rnSigType" <+> (ppr hs_ty $$ ppr free_vars $$
-                                        ppr real_rdrs))
+       ; traceRn "rnSigType" (ppr hs_ty $$ ppr free_vars $$
+                                        ppr real_rdrs)
        ; vars <- mapM (newLocalBndrRn . L loc . unLoc) real_rdrs
        ; bindLocalNamesFV vars $
          thing_inside vars }
@@ -429,11 +429,10 @@ rnHsKind ctxt kind = rnHsTyKi  (mkTyKiEnv ctxt KindLevel RnTypeBody) kind
 --------------
 rnTyKiContext :: RnTyKiEnv -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
 rnTyKiContext env (L loc cxt)
-  = do { traceRn (text "rncontext" <+> ppr cxt)
+  = do { traceRn "rncontext" (ppr cxt)
        ; let env' = env { rtke_what = RnConstraint }
        ; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt
        ; return (L loc cxt', fvs) }
-  where
 
 rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
 rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta
@@ -892,10 +891,10 @@ bindLHsTyVarBndrs doc mb_in_doc mb_assoc kv_bndrs tv_bndrs thing_inside
                                | v <- all_rn_tvs
                                , let name = hsLTyVarName v
                                , name `elemNameSet` all_dep_vars ]
-           ; traceRn (text "bindHsTyVars" <+> (ppr env $$
-                                               ppr all_rn_kvs $$
-                                               ppr all_rn_tvs $$
-                                               ppr exp_dep_vars))
+           ; traceRn "bindHsTyVars" (ppr env $$
+                                     ppr all_rn_kvs $$
+                                     ppr all_rn_tvs $$
+                                     ppr exp_dep_vars)
            ; thing_inside all_rn_kvs all_rn_tvs exp_dep_vars all_dep_vars }
 
     warn_unused tv_bndr fvs = case mb_in_doc of
index 6c800f4..89623b5 100644 (file)
@@ -238,7 +238,7 @@ tcRnModuleTcRnM hsc_env hsc_src
         setGblEnv tcg_env1 $ do {
 
                 -- Rename and type check the declarations
-        traceRn (text "rn1a") ;
+        traceRn "rn1a" empty ;
         tcg_env <- if isHsBootOrSig hsc_src then
                         tcRnHsBootDecls hsc_src local_decls
                    else
@@ -247,9 +247,9 @@ tcRnModuleTcRnM hsc_env hsc_src
         setGblEnv tcg_env               $ do {
 
                 -- Process the export list
-        traceRn (text "rn4a: before exports");
+        traceRn "rn4a: before exports" empty;
         tcg_env <- tcRnExports explicit_mod_hdr export_ies tcg_env ;
-        traceRn (text "rn4b: after exports") ;
+        traceRn "rn4b: after exports" empty ;
 
                 -- Check that main is exported (must be after rnExports)
         checkMainExported tcg_env ;
@@ -330,7 +330,7 @@ tcRnImports hsc_env import_decls
               tcg_hpc          = hpc_info
             }) $ do {
 
-        ; traceRn (text "rn1" <+> ppr (imp_dep_mods imports))
+        ; traceRn "rn1" (ppr (imp_dep_mods imports))
                 -- Fail if there are any errors so far
                 -- The error printing (if needed) takes advantage
                 -- of the tcg_env we have now set
@@ -345,7 +345,7 @@ tcRnImports hsc_env import_decls
                                (filter (/= this_mod) (imp_orphs imports))
 
                 -- Check type-family consistency
-        ; traceRn (text "rn1: checking family instance consistency")
+        ; traceRn "rn1: checking family instance consistency" empty
         ; let { dir_imp_mods = moduleEnvKeys
                              . imp_mods
                              $ imports }
@@ -1177,9 +1177,9 @@ rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
 -- Fails if there are any errors
 rnTopSrcDecls group
  = do { -- Rename the source decls
-        traceRn (text "rn12") ;
+        traceRn "rn12" empty ;
         (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ;
-        traceRn (text "rn13") ;
+        traceRn "rn13" empty ;
 
         -- save the renamed syntax, if we want it
         let { tcg_env'
@@ -1915,7 +1915,7 @@ tcUserStmt rdr_stmt@(L loc _)
              fix_env <- getFixityEnv
              return (fix_env, emptyFVs)
             -- Don't try to typecheck if the renamer fails!
-       ; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs])
+       ; traceRn "tcRnStmt" (vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs])
        ; rnDump (ppr rn_stmt) ;
 
        ; ghciStep <- getGhciStepIO
index e04c384..14c151b 100644 (file)
@@ -137,11 +137,11 @@ tcRnExports explicit_mod exports
                         --       turns out to be out of scope
 
         ; (rn_exports, avails) <- exports_from_avail real_exports rdr_env imports this_mod
-        ; traceRn (ppr avails)
+        ; traceRn "Exported Avails" (ppr avails)
         ; let final_avails = nubAvails avails    -- Combine families
               final_ns     = availsToNameSetWithSelectors final_avails
 
-        ; traceRn (text "rnExports: Exports:" <+> ppr final_avails)
+        ; traceRn "rnExports: Exports:" (ppr final_avails)
 
         ; let new_tcg_env =
                   tcg_env { tcg_exports    = final_avails,
@@ -221,7 +221,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
                       (exportValid && null gre_prs)
                       (nullModuleExport mod)
 
-             ; traceRn (text "efa" <+> (ppr mod $$ ppr all_gres))
+             ; traceRn "efa" (ppr mod $$ ppr all_gres)
              ; addUsedGREs all_gres
 
              ; occs' <- check_occs (IEModuleContents (noLoc mod)) occs names
@@ -231,7 +231,8 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
                       -- 'M.x' is in scope in several ways, we'll have
                       -- several members of mod_avails with the same
                       -- OccName.
-             ; traceRn (vcat [ text "export mod" <+> ppr mod
+             ; traceRn "export_mod"
+                       (vcat [ ppr mod
                              , ppr new_exports ])
              ; return (ExportAccum (L loc (IEModuleContents (L lm mod)) : ie_names)
                                    occs'
@@ -463,7 +464,7 @@ lookupExportChild parent rdr_name
   -- The remaining GREs are things that we *could* export here, note that
   -- this includes things which have `NoParent`. Those are sorted in
   -- `checkPatSynParent`.
-  traceRn (text "lookupExportChild original_gres:" <+> ppr original_gres)
+  traceRn "lookupExportChild original_gres:" (ppr original_gres)
   case picked_gres original_gres of
     NoOccurence ->
       noMatchingParentErr original_gres
index ada89f1..e2c5938 100644 (file)
@@ -41,7 +41,6 @@ module TcRnMonad(
   traceTc, traceRn, traceOptTcRn, traceTcRn,
   getPrintUnqualified,
   printForUserTcRn,
-  debugDumpTcRn,
   traceIf, traceHiDiffs, traceOptIf,
   debugTc,
 
@@ -659,18 +658,27 @@ updTcRef ref fn = liftIO $ do { old <- readIORef ref
 ************************************************************************
 -}
 
+
+-- Typechecker trace
 traceTc :: String -> SDoc -> TcRn ()
-traceTc herald doc = traceTcN 1 (hang (text herald) 2 doc)
+traceTc =
+  guardedTraceOptTcRn Opt_D_dump_tc_trace
+
+-- Renamer Trace
+traceRn :: String -> SDoc -> TcRn ()
+traceRn =
+  guardedTraceOptTcRn Opt_D_dump_rn_trace
 
--- | Typechecker trace
-traceTcN :: Int -> SDoc -> TcRn ()
-traceTcN level doc
-    = do dflags <- getDynFlags
-         when (level <= traceLevel dflags && not opt_NoDebugOutput) $
-             traceOptTcRn Opt_D_dump_tc_trace doc
+-- | Do not display a trace if `-dno-debug-output` is on or `-dtrace-level=0`.
+guardedTraceOptTcRn :: DumpFlag -> String -> SDoc -> TcRn ()
+guardedTraceOptTcRn flag herald doc = do
+  dflags <- getDynFlags
+  when ( traceLevel dflags >= 1
+         && not opt_NoDebugOutput)
+       ( traceOptTcRn flag (formatTraceMsg herald doc) )
 
-traceRn :: SDoc -> TcRn ()
-traceRn = traceOptTcRn Opt_D_dump_rn_trace -- Renamer Trace
+formatTraceMsg :: String -> SDoc -> SDoc
+formatTraceMsg herald doc = hang (text herald) 2 doc
 
 -- | Output a doc if the given 'DumpFlag' is set.
 --
@@ -682,8 +690,10 @@ traceRn = traceOptTcRn Opt_D_dump_rn_trace -- Renamer Trace
 traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
 traceOptTcRn flag doc
   = do { dflags <- getDynFlags
-       ; when (dopt flag dflags) (traceTcRn flag doc)
-    }
+       ; when (dopt flag dflags)
+              (traceTcRn flag doc)
+       }
+
 
 traceTcRn :: DumpFlag -> SDoc -> TcRn ()
 -- ^ Unconditionally dump some trace output
@@ -716,11 +726,6 @@ printForUserTcRn doc
        ; printer <- getPrintUnqualified dflags
        ; liftIO (printOutputForUser dflags printer doc) }
 
--- | Typechecker debug
-debugDumpTcRn :: SDoc -> TcRn ()
-debugDumpTcRn doc = unless opt_NoDebugOutput $
-                    traceOptTcRn Opt_D_dump_tc doc
-
 {-
 traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is
 available.  Alas, they behave inconsistently with the other stuff;
@@ -1579,7 +1584,7 @@ getTopLevelSpliceLocs
 keepAlive :: Name -> TcRn ()     -- Record the name in the keep-alive set
 keepAlive name
   = do { env <- getGblEnv
-       ; traceRn (text "keep alive" <+> ppr name)
+       ; traceRn "keep alive" (ppr name)
        ; updTcRef (tcg_keep env) (`extendNameSet` name) }
 
 getStage :: TcM ThStage
index 61abe35..b4f084f 100644 (file)
@@ -233,13 +233,14 @@ test('T4801',
            # 2014-09-03:  185242032 (Windows laptop)
            # 2014-12-01:  203962148 (Windows laptop)
            # 2016-04-06:  239556572 (x86/Linux)
-           (wordsize(64), 434278248, 10)]),
+           (wordsize(64), 388898280, 10)]),
             # prev:       360243576 (amd64/Linux)
             # 19/10/2012: 447190832 (amd64/Linux) (-fPIC turned on)
             # 19/10/2012: 392409984 (amd64/Linux) (-fPIC turned off)
             # 2014-04-08: 362939272 (amd64/Linux) cumulation of various smaller improvements over recent commits
             # 2014-10-08: 382056344 (amd64/Linux) stricter foldr2 488e95b
             # 2015-10-28: 434278248 (amd64/Linux) emit Typeable at definition site
+            # 2016-10-19: 388898280 (amd64/Linux) Refactor traceRn interface (#12617)
 
 ###################################
 # deactivated for now, as this metric became too volatile recently
@@ -415,7 +416,7 @@ test('T5631',
         # 2014-04-04:     346389856 (x86 Windows, 64 bit machine)
         # 2014-12-01:     390199244 (Windows laptop)
         # 2016-04-06:     570137436 (amd64/Linux) many reasons
-           (wordsize(64), 1124068664, 5)]),
+           (wordsize(64), 1024926024, 5)]),
         # expected value: 774595008 (amd64/Linux):
         # expected value: 735486328 (amd64/Linux) 2012/12/12:
         # expected value: 690742040 (amd64/Linux) Call Arity improvements
@@ -425,6 +426,7 @@ test('T5631',
         # 2015-12-11:     1128828928 (amd64/Linux) TypeInType (see #11196)
         # 2015-12-21:     1198327544 (Mac) TypeApplications (will fix with #11196)
         # 2015-03-18:     1124068664 (Mac) optimize Unify & zonking
+        # 2016-10-19:     1024926024 (amd64/Linux) Refactor traceRn interface (#12617)
        only_ways(['normal'])
       ],
      compile,
@@ -705,12 +707,13 @@ test('T9675',
 test('T9872a',
      [ only_ways(['normal']),
        compiler_stats_num_field('bytes allocated',
-          [(wordsize(64), 3352882080, 5),
+          [(wordsize(64), 3134866040    , 5),
           # 2014-12-10    5521332656    Initally created
           # 2014-12-16    5848657456    Flattener parameterized over roles
           # 2014-12-18    2680733672    Reduce type families even more eagerly
           # 2015-12-11    3581500440    TypeInType (see #11196)
           # 2016-04-07    3352882080    CSE improvements
+          # 2016-10-19    3134866040    Refactor traceRn interface (#12617)
            (wordsize(32), 1740903516, 5)
           # was           1325592896
           # 2016-04-06    1740903516    x86/Linux