warnPprTrace: pass separately the reason

This makes it more similar to pprTrace, pprPanic etc.

compiler/GHC/CmmToC.hs

@@ -1113,7 +1113,7 @@ pprReg r = case r of
 
 pprAsPtrReg :: CmmReg -> SDoc
 pprAsPtrReg (CmmGlobal (VanillaReg n gcp))
-  = warnPprTrace (gcp /= VGcPtr) (ppr n) $ char 'R' <> int n <> text ".p"
+  = warnPprTrace (gcp /= VGcPtr) "pprAsPtrReg" (ppr n) $ char 'R' <> int n <> text ".p"
 pprAsPtrReg other_reg = pprReg other_reg
 
 pprGlobalReg :: GlobalReg -> SDoc

compiler/GHC/Core/Coercion/Opt.hs

@@ -296,7 +296,8 @@ opt_co4 env sym rep r (CoVarCo cv)
     cv1 = case lookupInScope (lcInScopeSet env) cv of
              Just cv1 -> cv1
              Nothing  -> warnPprTrace True
-                          (text "opt_co: not in scope:" <+> ppr cv $$ ppr env)
+                          "opt_co: not in scope"
+                          (ppr cv $$ ppr env)
                           cv
           -- cv1 might have a substituted kind!
 

compiler/GHC/Core/Opt/Arity.hs

@@ -655,8 +655,8 @@ findRhsArity dflags bndr rhs old_arity
       | otherwise               =
          -- Warn if more than 2 iterations. Why 2? See Note [Exciting arity]
          warnPprTrace (debugIsOn && n > 2)
-            (text "Exciting arity" $$ nest 2
-              ( ppr bndr <+> ppr cur_at <+> ppr next_at $$ ppr rhs)) $
+            "Exciting arity"
+            (nest 2 (ppr bndr <+> ppr cur_at <+> ppr next_at $$ ppr rhs)) $
             go (n+1) next_at
       where
         next_at = step cur_at
@@ -1622,7 +1622,7 @@ mkEtaWW orig_oss ppr_orig_expr in_scope orig_ty
        | otherwise       -- We have an expression of arity > 0,
                          -- but its type isn't a function, or a binder
                          -- does not have a fixed runtime representation
-       = warnPprTrace True ((ppr orig_oss <+> ppr orig_ty) $$ ppr_orig_expr)
+       = warnPprTrace True "mkEtaWW" ((ppr orig_oss <+> ppr orig_ty) $$ ppr_orig_expr)
          (getTCvInScope subst, EI [] MRefl)
         -- This *can* legitimately happen:
         -- e.g.  coerce Int (\x. x) Essentially the programmer is
@@ -1938,7 +1938,7 @@ etaExpandToJoinPoint join_arity expr
 
 etaExpandToJoinPointRule :: JoinArity -> CoreRule -> CoreRule
 etaExpandToJoinPointRule _ rule@(BuiltinRule {})
-  = warnPprTrace True (sep [text "Can't eta-expand built-in rule:", ppr rule])
+  = warnPprTrace True "Can't eta-expand built-in rule:" (ppr rule)
       -- How did a local binding get a built-in rule anyway? Probably a plugin.
     rule
 etaExpandToJoinPointRule join_arity rule@(Rule { ru_bndrs = bndrs, ru_rhs = rhs

compiler/GHC/Core/Opt/ConstantFold.hs

@@ -1815,7 +1815,7 @@ tagToEnumRule = do
       return $ mkTyApps (Var (dataConWorkId dc)) tc_args
 
     -- See Note [tagToEnum#]
-    _ -> warnPprTrace True (text "tagToEnum# on non-enumeration type" <+> ppr ty) $
+    _ -> warnPprTrace True "tagToEnum# on non-enumeration type" (ppr ty) $
          return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type"
 
 ------------------------------

compiler/GHC/Core/Opt/OccurAnal.hs

@@ -82,8 +82,7 @@ occurAnalysePgm this_mod active_unf active_rule imp_rules binds
   = occ_anald_binds
 
   | otherwise   -- See Note [Glomming]
-  = warnPprTrace True (hang (text "Glomming in" <+> ppr this_mod <> colon)
-                        2 (ppr final_usage))
+  = warnPprTrace True "Glomming in" (hang (ppr this_mod <> colon) 2 (ppr final_usage))
     occ_anald_glommed_binds
   where
     init_env = initOccEnv { occ_rule_act = active_rule
@@ -3131,7 +3130,7 @@ decideJoinPointHood TopLevel _ _
 decideJoinPointHood NotTopLevel usage bndrs
   | isJoinId (head bndrs)
   = warnPprTrace (not all_ok)
-                 (text "OccurAnal failed to rediscover join point(s):" <+> ppr bndrs)
+                 "OccurAnal failed to rediscover join point(s)" (ppr bndrs)
                  all_ok
   | otherwise
   = all_ok

compiler/GHC/Core/Opt/Pipeline.hs

@@ -690,7 +690,8 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
         -- about to begin, with '1' for the first
       | iteration_no > max_iterations   -- Stop if we've run out of iterations
       = warnPprTrace (debugIsOn && (max_iterations > 2))
-            ( hang (ppr this_mod <> colon <+> text "simplifier bailing out after"
+            "Simplifier bailing out"
+            ( hang (ppr this_mod <> text ", after"
                     <+> int max_iterations <+> text "iterations"
                     <+> (brackets $ hsep $ punctuate comma $
                          map (int . simplCountN) (reverse counts_so_far)))
@@ -995,7 +996,7 @@ shortMeOut ind_env exported_id local_id
     then
         if hasShortableIdInfo exported_id
         then True       -- See Note [Messing up the exported Id's IdInfo]
-        else warnPprTrace True (text "Not shorting out:" <+> ppr exported_id) False
+        else warnPprTrace True "Not shorting out" (ppr exported_id) False
     else
         False
 

compiler/GHC/Core/Opt/SetLevels.hs

@@ -1703,7 +1703,7 @@ abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs
         -- and add the tyvars of the Id (if necessary)
     zap v | isId v = warnPprTrace (isStableUnfolding (idUnfolding v) ||
                            not (isEmptyRuleInfo (idSpecialisation v)))
-                           (text "absVarsOf: discarding info on" <+> ppr v) $
+                           "absVarsOf: discarding info on" (ppr v) $
                      setIdInfo v vanillaIdInfo
           | otherwise = v
 

compiler/GHC/Core/Opt/Simplify.hs

@@ -3170,6 +3170,7 @@ addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv
 addBinderUnfolding env bndr unf
   | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf
   = warnPprTrace (not (eqType (idType bndr) (exprType tmpl)))
+          "unfolding type mismatch"
           (ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl)) $
           modifyInScope env (bndr `setIdUnfolding` unf)
 
@@ -3336,7 +3337,7 @@ missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont
                 -- it "sees" that the entire branch of an outer case is
                 -- inaccessible.  So we simply put an error case here instead.
 missingAlt env case_bndr _ cont
-  = warnPprTrace True (text "missingAlt" <+> ppr case_bndr) $
+  = warnPprTrace True "missingAlt" (ppr case_bndr) $
     -- See Note [Avoiding space leaks in OutType]
     let cont_ty = contResultType cont
     in seqType cont_ty `seq`

compiler/GHC/Core/Opt/Simplify/Utils.hs

@@ -568,7 +568,7 @@ mkArgInfo env fun rules n_val_args call_cont
                    else
                         demands ++ vanilla_dmds
                | otherwise
-               -> warnPprTrace True (text "More demands than arity" <+> ppr fun <+> ppr (idArity fun)
+               -> warnPprTrace True "More demands than arity" (ppr fun <+> ppr (idArity fun)
                                 <+> ppr n_val_args <+> ppr demands) $
                   vanilla_dmds      -- Not enough args, or no strictness
 

compiler/GHC/Core/Opt/SpecConstr.hs

@@ -2226,8 +2226,8 @@ callToPats env bndr_occs call@(Call fn args con_env)
 
         ; -- pprTrace "callToPats"  (ppr args $$ ppr bndr_occs) $
           warnPprTrace (not (isEmptyVarSet bad_covars))
-              ( text "SpecConstr: bad covars:" <+> ppr bad_covars
-                $$ ppr call) $
+              "SpecConstr: bad covars"
+              (ppr bad_covars $$ ppr call) $
           if interesting && isEmptyVarSet bad_covars
           then
               -- pprTraceM "callToPatsOut" (
@@ -2530,7 +2530,7 @@ samePat (CP { cp_qvars = vs1, cp_args = as1 })
     same e1 (Tick _ e2) = same e1 e2
     same e1 (Cast e2 _) = same e1 e2
 
-    same e1 e2 = warnPprTrace (bad e1 || bad e2) (ppr e1 $$ ppr e2) $
+    same e1 e2 = warnPprTrace (bad e1 || bad e2) "samePat" (ppr e1 $$ ppr e2) $
                  False  -- Let, lambda, case should not occur
     bad (Case {}) = True
     bad (Let {})  = True

compiler/GHC/Core/Opt/Specialise.hs

@@ -1442,7 +1442,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
 
   | otherwise   -- No calls or RHS doesn't fit our preconceptions
   = warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me)
-          (text "Missed specialisation opportunity for" <+> ppr fn $$ _trace_doc) $
+          "Missed specialisation opportunity" (ppr fn $$ _trace_doc) $
           -- Note [Specialisation shape]
     -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $
     return ([], [], emptyUDs)

compiler/GHC/Core/Opt/WorkWrap.hs

@@ -723,6 +723,7 @@ by LitRubbish (see Note [Drop absent bindings]) so there is no great harm.
 splitFun :: WwOpts -> Id -> CoreExpr -> UniqSM [(Id, CoreExpr)]
 splitFun ww_opts fn_id rhs
   = warnPprTrace (not (wrap_dmds `lengthIs` (arityInfo fn_info)))
+                 "splitFun"
                  (ppr fn_id <+> (ppr wrap_dmds $$ ppr cpr)) $
     do { mb_stuff <- mkWwBodies ww_opts fn_id arg_vars (exprType body) wrap_dmds cpr
        ; case mb_stuff of

compiler/GHC/Core/Opt/WorkWrap/Utils.hs

@@ -280,8 +280,8 @@ mkWwBodies opts fun_id arg_vars res_ty demands res_cpr
     too_many_args_for_join_point wrap_args
       | Just join_arity <- mb_join_arity
       , wrap_args `lengthExceeds` join_arity
-      = warnPprTrace True (text "Unable to worker/wrapper join point with arity " <+>
-                     int join_arity <+> text "but" <+>
+      = warnPprTrace True "Unable to worker/wrapper join point"
+                     (text "arity" <+> int join_arity <+> text "but" <+>
                      int (length wrap_args) <+> text "args") $
         True
       | otherwise
@@ -610,7 +610,7 @@ wantToUnboxResult fam_envs ty cpr
 
   where
     -- | See Note [non-algebraic or open body type warning]
-    open_body_ty_warning = warnPprTrace True (text "wantToUnboxResult: non-algebraic or open body type" <+> ppr ty) Nothing
+    open_body_ty_warning = warnPprTrace True "wantToUnboxResult: non-algebraic or open body type" (ppr ty) Nothing
 
 isLinear :: Scaled a -> Bool
 isLinear (Scaled w _ ) =

compiler/GHC/Core/Utils.hs

@@ -293,8 +293,9 @@ mkCast (Coercion e_co) co
 
 mkCast (Cast expr co2) co
   = warnPprTrace (let { from_ty = coercionLKind co;
-               to_ty2  = coercionRKind co2 } in
-            not (from_ty `eqType` to_ty2))
+                        to_ty2  = coercionRKind co2 } in
+                     not (from_ty `eqType` to_ty2))
+             "mkCast"
              (vcat ([ text "expr:" <+> ppr expr
                    , text "co2:" <+> ppr co2
                    , text "co:" <+> ppr co ])) $
@@ -306,7 +307,7 @@ mkCast (Tick t expr) co
 mkCast expr co
   = let from_ty = coercionLKind co in
     warnPprTrace (not (from_ty `eqType` exprType expr))
-          (text "Trying to coerce" <+> text "(" <> ppr expr
+          "Trying to coerce" (text "(" <> ppr expr
           $$ text "::" <+> ppr (exprType expr) <> text ")"
           $$ ppr co $$ ppr (coercionType co)
           $$ callStackDoc) $

compiler/GHC/CoreToIface.hs

@@ -372,7 +372,7 @@ toIfaceAppArgsX fr kind ty_args
         -- This is probably a compiler bug, so we print a trace and
         -- carry on as if it were FunTy.  Without the test for
         -- isEmptyTCvSubst we'd get an infinite loop (#15473)
-        warnPprTrace True (ppr kind $$ ppr ty_args) $
+        warnPprTrace True "toIfaceAppArgsX" (ppr kind $$ ppr ty_args) $
         IA_Arg (toIfaceTypeX fr t1) Required (go env ty ts1)
 
 tidyToIfaceType :: TidyEnv -> Type -> IfaceType

compiler/GHC/CoreToStg.hs

@@ -620,7 +620,7 @@ coreToStgArgs (arg : args) = do         -- Non-type argument
         stg_arg_rep = typePrimRep (stgArgType stg_arg)
         bad_args = not (primRepsCompatible platform arg_rep stg_arg_rep)
 
-    warnPprTrace bad_args (text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg) $
+    warnPprTrace bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg) $
      return (stg_arg : stg_args, ticks ++ aticks)
 
 coreToStgTick :: Type -- type of the ticked expression

compiler/GHC/CoreToStg/Prep.hs

@@ -658,7 +658,7 @@ cpePair top_lvl is_rec dmd is_unlifted env bndr rhs
        ; (floats3, rhs3)
             <- if manifestArity rhs1 <= arity
                then return (floats2, cpeEtaExpand arity rhs2)
-               else warnPprTrace True (text "CorePrep: silly extra arguments:" <+> ppr bndr) $
+               else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $
                                -- Note [Silly extra arguments]
                     (do { v <- newVar (idType bndr)
                         ; let float = mkFloat topDmd False v rhs2

compiler/GHC/Data/List/SetOps.hs

@@ -66,7 +66,7 @@ unionLists xs [y]
   | isIn "unionLists" y xs = xs
   | otherwise = y:xs
 unionLists xs ys
-  = warnPprTrace (lengthExceeds xs 100 || lengthExceeds ys 100) (ppr xs $$ ppr ys) $
+  = warnPprTrace (lengthExceeds xs 100 || lengthExceeds ys 100) "unionLists" (ppr xs $$ ppr ys) $
     [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys
 
 -- | Calculate the set difference of two lists. This is
@@ -207,7 +207,7 @@ isIn msg x ys
     elem100 :: Eq a => Int -> a -> [a] -> Bool
     elem100 _ _ [] = False
     elem100 i x (y:ys)
-      | i > 100 = warnPprTrace True (text ("Over-long elem in " ++ msg)) (x `elem` (y:ys))
+      | i > 100 = warnPprTrace True ("Over-long elem in " ++ msg) empty (x `elem` (y:ys))
       | otherwise = x == y || elem100 (i + 1) x ys
 
 isn'tIn msg x ys
@@ -216,6 +216,6 @@ isn'tIn msg x ys
     notElem100 :: Eq a => Int -> a -> [a] -> Bool
     notElem100 _ _ [] =  True
     notElem100 i x (y:ys)
-      | i > 100 = warnPprTrace True (text ("Over-long notElem in " ++ msg)) (x `notElem` (y:ys))
+      | i > 100 = warnPprTrace True ("Over-long notElem in " ++ msg) empty (x `notElem` (y:ys))
       | otherwise = x /= y && notElem100 (i + 1) x ys
 # endif /* DEBUG */

compiler/GHC/Iface/Load.hs

@@ -540,7 +540,7 @@ loadInterface doc_str mod from
                             -- of one's own boot file! (one-shot only)
                             -- See Note [Loading your own hi-boot file]
 
-        ; warnPprTrace bad_boot (ppr mod) $
+        ; warnPprTrace bad_boot "loadInterface" (ppr mod) $
           updateEps_  $ \ eps ->
            if elemModuleEnv mod (eps_PIT eps) || is_external_sig mhome_unit iface
                 then eps

compiler/GHC/Iface/Make.hs

@@ -162,7 +162,7 @@ updateDecl decls (Just CgInfos{ cgNonCafs = NonCaffySet non_cafs, cgLFInfos = lf
     update_decl (IfaceId nm ty details infos)
       | let not_caffy = elemNameSet nm non_cafs
       , let mb_lf_info = lookupNameEnv lf_infos nm
-      , warnPprTrace (isNothing mb_lf_info) (text "Name without LFInfo:" <+> ppr nm) True
+      , warnPprTrace (isNothing mb_lf_info) "Name without LFInfo" (ppr nm) True
         -- Only allocate a new IfaceId if we're going to update the infos
       , isJust mb_lf_info || not_caffy
       = IfaceId nm ty details $