Commit 23d215fc authored by Krzysztof Gogolewski's avatar Krzysztof Gogolewski Committed by Marge Bot
Browse files

warnPprTrace: pass separately the reason

This makes it more similar to pprTrace, pprPanic etc.
parent 49731fed
Pipeline #46026 canceled with stages
in 29 seconds
......@@ -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
......
......@@ -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!
......
......@@ -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
......
......@@ -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"
------------------------------
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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`
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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 _ ) =
......
......@@ -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) $
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 */
......@@ -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
......
......@@ -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 $
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment