diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2021-05-06 22:22:02 +0200 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-05-12 21:41:44 -0400 |
| commit | 0ef119071347f7bc14f0fa89904b0cfd0b230ac1 (patch) | |
| tree | 7a80b3942ae6bd18391f9b924ad55bb001392288 /compiler/GHC/Core | |
| parent | bfabf94f63b6644bd32982fd13ea0c8bca9aeae4 (diff) | |
| download | haskell-0ef119071347f7bc14f0fa89904b0cfd0b230ac1.tar.gz | |
Fully remove HsVersions.h
Replace uses of WARN macro with calls to:
warnPprTrace :: Bool -> SDoc -> a -> a
Remove the now unused HsVersions.h
Bump haddock submodule
Diffstat (limited to 'compiler/GHC/Core')
48 files changed, 52 insertions, 151 deletions
diff --git a/compiler/GHC/Core/Class.hs b/compiler/GHC/Core/Class.hs index b6648ceaac..8319526322 100644 --- a/compiler/GHC/Core/Class.hs +++ b/compiler/GHC/Core/Class.hs @@ -21,8 +21,6 @@ module GHC.Core.Class ( isAbstractClass, ) where -#include "HsVersions.h" - import GHC.Prelude import {-# SOURCE #-} GHC.Core.TyCon ( TyCon ) diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs index e0957c0278..e8207bad35 100644 --- a/compiler/GHC/Core/Coercion.hs +++ b/compiler/GHC/Core/Coercion.hs @@ -127,8 +127,6 @@ module GHC.Core.Coercion ( HoleSet, coercionHolesOfType, coercionHolesOfCo ) where -#include "HsVersions.h" - import {-# SOURCE #-} GHC.CoreToIface (toIfaceTyCon, tidyToIfaceTcArgs) import GHC.Prelude diff --git a/compiler/GHC/Core/Coercion/Axiom.hs b/compiler/GHC/Core/Coercion/Axiom.hs index e48ed2bd42..f9ec62e973 100644 --- a/compiler/GHC/Core/Coercion/Axiom.hs +++ b/compiler/GHC/Core/Coercion/Axiom.hs @@ -56,8 +56,6 @@ import qualified Data.Data as Data import Data.Array import Data.List ( mapAccumL ) -#include "HsVersions.h" - {- Note [Coercion axiom branches] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Core/Coercion/Opt.hs b/compiler/GHC/Core/Coercion/Opt.hs index 81def895e0..85b6e93ec1 100644 --- a/compiler/GHC/Core/Coercion/Opt.hs +++ b/compiler/GHC/Core/Coercion/Opt.hs @@ -9,8 +9,6 @@ module GHC.Core.Coercion.Opt ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Driver.Ppr @@ -294,9 +292,9 @@ opt_co4 env sym rep r (CoVarCo cv) cv1 = case lookupInScope (lcInScopeSet env) cv of Just cv1 -> cv1 - Nothing -> WARN( True, text "opt_co: not in scope:" - <+> ppr cv $$ ppr env) - cv + Nothing -> warnPprTrace True + (text "opt_co: not in scope:" <+> ppr cv $$ ppr env) + cv -- cv1 might have a substituted kind! opt_co4 _ _ _ _ (HoleCo h) diff --git a/compiler/GHC/Core/ConLike.hs b/compiler/GHC/Core/ConLike.hs index bbdab332a7..2c2a21d3ab 100644 --- a/compiler/GHC/Core/ConLike.hs +++ b/compiler/GHC/Core/ConLike.hs @@ -25,8 +25,6 @@ module GHC.Core.ConLike ( , conLikeHasBuilder ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Core.DataCon diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs index 4714b3be01..2a29a9aac4 100644 --- a/compiler/GHC/Core/DataCon.hs +++ b/compiler/GHC/Core/DataCon.hs @@ -63,8 +63,6 @@ module GHC.Core.DataCon ( promoteDataCon ) where -#include "HsVersions.h" - import GHC.Prelude import {-# SOURCE #-} GHC.Types.Id.Make ( DataConBoxer ) diff --git a/compiler/GHC/Core/FVs.hs b/compiler/GHC/Core/FVs.hs index d21407d42b..af23ffb45a 100644 --- a/compiler/GHC/Core/FVs.hs +++ b/compiler/GHC/Core/FVs.hs @@ -56,8 +56,6 @@ module GHC.Core.FVs ( freeVarsOfAnn ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Core diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs index 4b41f40dee..b4b2100705 100644 --- a/compiler/GHC/Core/FamInstEnv.hs +++ b/compiler/GHC/Core/FamInstEnv.hs @@ -38,8 +38,6 @@ module GHC.Core.FamInstEnv ( topReduceTyFamApp_maybe, reduceTyFamApp_maybe ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Core.Unify diff --git a/compiler/GHC/Core/InstEnv.hs b/compiler/GHC/Core/InstEnv.hs index 55f96a1b18..02f2183d63 100644 --- a/compiler/GHC/Core/InstEnv.hs +++ b/compiler/GHC/Core/InstEnv.hs @@ -29,8 +29,6 @@ module GHC.Core.InstEnv ( isOverlappable, isOverlapping, isIncoherent ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Tc.Utils.TcType -- InstEnv is really part of the type checker, diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index aa26fdabc4..86be68cdb6 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -25,8 +25,6 @@ module GHC.Core.Lint ( dumpIfSet, ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Driver.Session diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs index 46ea720ec2..b174379bc9 100644 --- a/compiler/GHC/Core/Make.hs +++ b/compiler/GHC/Core/Make.hs @@ -52,8 +52,6 @@ module GHC.Core.Make ( tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Platform diff --git a/compiler/GHC/Core/Map/Expr.hs b/compiler/GHC/Core/Map/Expr.hs index 30be6adea2..8d47a947b4 100644 --- a/compiler/GHC/Core/Map/Expr.hs +++ b/compiler/GHC/Core/Map/Expr.hs @@ -24,8 +24,6 @@ module GHC.Core.Map.Expr ( (>.>), (|>), (|>>), ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Data.TrieMap diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs index 73f8135a46..004e667e1b 100644 --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -30,8 +30,6 @@ module GHC.Core.Opt.Arity ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Driver.Ppr @@ -655,11 +653,10 @@ findRhsArity dflags bndr rhs old_arity | next_at == cur_at = cur_at | otherwise = -- Warn if more than 2 iterations. Why 2? See Note [Exciting arity] - WARN( debugIsOn && n > 2, text "Exciting arity" - $$ nest 2 ( - ppr bndr <+> ppr cur_at <+> ppr next_at - $$ ppr rhs) ) - go (n+1) next_at + warnPprTrace (debugIsOn && n > 2) + (text "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 @@ -1556,7 +1553,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 -- is levity-polymorphic - = WARN( True, (ppr orig_oss <+> ppr orig_ty) $$ ppr_orig_expr ) + = warnPprTrace True ((ppr orig_oss <+> ppr orig_ty) $$ ppr_orig_expr) (getTCvInScope subst, reverse eis) -- This *can* legitimately happen: -- e.g. coerce Int (\x. x) Essentially the programmer is @@ -1862,7 +1859,7 @@ etaExpandToJoinPoint join_arity expr etaExpandToJoinPointRule :: JoinArity -> CoreRule -> CoreRule etaExpandToJoinPointRule _ rule@(BuiltinRule {}) - = WARN(True, (sep [text "Can't eta-expand built-in rule:", ppr rule])) + = warnPprTrace True (sep [text "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 diff --git a/compiler/GHC/Core/Opt/CSE.hs b/compiler/GHC/Core/Opt/CSE.hs index 9855c41731..cb5d446fa5 100644 --- a/compiler/GHC/Core/Opt/CSE.hs +++ b/compiler/GHC/Core/Opt/CSE.hs @@ -11,8 +11,6 @@ module GHC.Core.Opt.CSE (cseProgram, cseOneExpr) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Core.Subst diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs index 1402a021f7..68ac1379e8 100644 --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/compiler/GHC/Core/Opt/ConstantFold.hs @@ -31,8 +31,6 @@ module GHC.Core.Opt.ConstantFold ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Driver.Ppr @@ -1541,7 +1539,7 @@ tagToEnumRule = do return $ mkTyApps (Var (dataConWorkId dc)) tc_args -- See Note [tagToEnum#] - _ -> WARN( True, text "tagToEnum# on non-enumeration type" <+> ppr ty ) + _ -> warnPprTrace True (text "tagToEnum# on non-enumeration type" <+> ppr ty) $ return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type" ------------------------------ diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs index 6c76671c4b..25dc82d42f 100644 --- a/compiler/GHC/Core/Opt/CprAnal.hs +++ b/compiler/GHC/Core/Opt/CprAnal.hs @@ -9,8 +9,6 @@ -- See Note [Phase ordering]. module GHC.Core.Opt.CprAnal ( cprAnalProgram ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Driver.Session diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index ac049c0212..61aa9bfc46 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -15,8 +15,6 @@ module GHC.Core.Opt.DmdAnal ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Core.Opt.WorkWrap.Utils diff --git a/compiler/GHC/Core/Opt/FloatIn.hs b/compiler/GHC/Core/Opt/FloatIn.hs index 78e993a26a..f1e9b044e8 100644 --- a/compiler/GHC/Core/Opt/FloatIn.hs +++ b/compiler/GHC/Core/Opt/FloatIn.hs @@ -18,8 +18,6 @@ then discover that they aren't needed in the chosen branch. module GHC.Core.Opt.FloatIn ( floatInwards ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Platform diff --git a/compiler/GHC/Core/Opt/FloatOut.hs b/compiler/GHC/Core/Opt/FloatOut.hs index c66ae34fa9..b0c7db67c3 100644 --- a/compiler/GHC/Core/Opt/FloatOut.hs +++ b/compiler/GHC/Core/Opt/FloatOut.hs @@ -35,8 +35,6 @@ import qualified Data.IntMap as M import Data.List ( partition ) -#include "HsVersions.h" - {- ----------------- Overall game plan diff --git a/compiler/GHC/Core/Opt/LiberateCase.hs b/compiler/GHC/Core/Opt/LiberateCase.hs index e9140612f0..6efae425f2 100644 --- a/compiler/GHC/Core/Opt/LiberateCase.hs +++ b/compiler/GHC/Core/Opt/LiberateCase.hs @@ -7,8 +7,6 @@ {-# LANGUAGE CPP #-} module GHC.Core.Opt.LiberateCase ( liberateCase ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Driver.Session diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs index c7b13f17c0..034f44176f 100644 --- a/compiler/GHC/Core/Opt/OccurAnal.hs +++ b/compiler/GHC/Core/Opt/OccurAnal.hs @@ -19,8 +19,6 @@ core expression with (hopefully) improved usage information. module GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Driver.Ppr @@ -82,8 +80,8 @@ occurAnalysePgm this_mod active_unf active_rule imp_rules binds = occ_anald_binds | otherwise -- See Note [Glomming] - = WARN( True, hang (text "Glomming in" <+> ppr this_mod <> colon) - 2 (ppr final_usage ) ) + = warnPprTrace True (hang (text "Glomming in" <+> ppr this_mod <> colon) + 2 (ppr final_usage)) occ_anald_glommed_binds where init_env = initOccEnv { occ_rule_act = active_rule @@ -3106,9 +3104,9 @@ decideJoinPointHood TopLevel _ _ = False decideJoinPointHood NotTopLevel usage bndrs | isJoinId (head bndrs) - = WARN(not all_ok, text "OccurAnal failed to rediscover join point(s):" <+> - ppr bndrs) - all_ok + = warnPprTrace (not all_ok) + (text "OccurAnal failed to rediscover join point(s):" <+> ppr bndrs) + all_ok | otherwise = all_ok where diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs index c97f266052..ba75cab359 100644 --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -8,8 +8,6 @@ module GHC.Core.Opt.Pipeline ( core2core, simplifyExpr ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Driver.Session @@ -745,12 +743,12 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) -- iteration_no is the number of the iteration we are -- about to begin, with '1' for the first | iteration_no > max_iterations -- Stop if we've run out of iterations - = WARN( debugIsOn && (max_iterations > 2) - , hang (text "Simplifier bailing out after" <+> int max_iterations + = warnPprTrace (debugIsOn && (max_iterations > 2)) + ( hang (text "Simplifier bailing out after" <+> int max_iterations <+> text "iterations" <+> (brackets $ hsep $ punctuate comma $ map (int . simplCountN) (reverse counts_so_far))) - 2 (text "Size =" <+> ppr (coreBindsStats binds))) + 2 (text "Size =" <+> ppr (coreBindsStats binds))) $ -- Subtract 1 from iteration_no to get the -- number of iterations we actually completed @@ -1050,8 +1048,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 WARN( True, text "Not shorting out:" <+> ppr exported_id ) - False + else warnPprTrace True (text "Not shorting out:" <+> ppr exported_id) False else False diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs index ed7f95b0b7..9d96dd3586 100644 --- a/compiler/GHC/Core/Opt/SetLevels.hs +++ b/compiler/GHC/Core/Opt/SetLevels.hs @@ -75,8 +75,6 @@ module GHC.Core.Opt.SetLevels ( incMinorLvl, ltMajLvl, ltLvl, isTopLvl ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Driver.Ppr @@ -1691,9 +1689,9 @@ abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs -- We are going to lambda-abstract, so nuke any IdInfo, -- and add the tyvars of the Id (if necessary) - zap v | isId v = WARN( isStableUnfolding (idUnfolding v) || - not (isEmptyRuleInfo (idSpecialisation v)), - text "absVarsOf: discarding info on" <+> ppr v ) + zap v | isId v = warnPprTrace (isStableUnfolding (idUnfolding v) || + not (isEmptyRuleInfo (idSpecialisation v))) + (text "absVarsOf: discarding info on" <+> ppr v) $ setIdInfo v vanillaIdInfo | otherwise = v diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index da15163ba6..3728b999ee 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -10,8 +10,6 @@ {-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns #-} module GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplRules ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Platform @@ -3098,9 +3096,9 @@ addAltUnfoldings env scrut case_bndr con_app addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv addBinderUnfolding env bndr unf | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf - = WARN( not (eqType (idType bndr) (exprType tmpl)), - ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl) ) - modifyInScope env (bndr `setIdUnfolding` unf) + = warnPprTrace (not (eqType (idType bndr) (exprType tmpl))) + (ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl)) $ + modifyInScope env (bndr `setIdUnfolding` unf) | otherwise = modifyInScope env (bndr `setIdUnfolding` unf) @@ -3264,7 +3262,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 - = WARN( True, text "missingAlt" <+> ppr case_bndr ) + = warnPprTrace True (text "missingAlt" <+> ppr case_bndr) $ -- See Note [Avoiding space leaks in OutType] let cont_ty = contResultType cont in seqType cont_ty `seq` @@ -3533,9 +3531,9 @@ mkDupableAlt platform case_bndr jfloats (Alt con bndrs' rhs') unf = mkInlineUnfolding simpl_opts rhs rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs' - LitAlt {} -> WARN( True, text "mkDupableAlt" - <+> ppr case_bndr <+> ppr con ) - case_bndr + LitAlt {} -> warnPprTrace True + (text "mkDupableAlt" <+> ppr case_bndr <+> ppr con) + case_bndr -- The case binder is alive but trivial, so why has -- it not been substituted away? diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs index 43d28cffe2..6cc102ca23 100644 --- a/compiler/GHC/Core/Opt/Simplify/Env.hs +++ b/compiler/GHC/Core/Opt/Simplify/Env.hs @@ -43,8 +43,6 @@ module GHC.Core.Opt.Simplify.Env ( wrapJoinFloats, wrapJoinFloatsX, unitJoinFloat, addJoinFlts ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Core.Opt.Simplify.Monad diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index 75f5acaace..61c8133bc2 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -37,8 +37,6 @@ module GHC.Core.Opt.Simplify.Utils ( isExitJoinId ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Core.Opt.Simplify.Env @@ -564,8 +562,8 @@ mkArgInfo env fun rules n_val_args call_cont else demands ++ vanilla_dmds | otherwise - -> WARN( True, text "More demands than arity" <+> ppr fun <+> ppr (idArity fun) - <+> ppr n_val_args <+> ppr demands ) + -> warnPprTrace True (text "More demands than arity" <+> ppr fun <+> ppr (idArity fun) + <+> ppr n_val_args <+> ppr demands) $ vanilla_dmds -- Not enough args, or no strictness add_type_strictness :: Type -> [Demand] -> [Demand] diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs index c5745f8b2f..58e77d76eb 100644 --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -19,8 +19,6 @@ module GHC.Core.Opt.SpecConstr( SpecConstrAnnotation(..) ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Core @@ -2178,9 +2176,9 @@ callToPats env bndr_occs call@(Call fn args con_env) bad_covar v = isId v && not (is_in_scope v) ; -- pprTrace "callToPats" (ppr args $$ ppr bndr_occs) $ - WARN( not (isEmptyVarSet bad_covars) - , text "SpecConstr: bad covars:" <+> ppr bad_covars - $$ ppr call ) + warnPprTrace (not (isEmptyVarSet bad_covars)) + ( text "SpecConstr: bad covars:" <+> ppr bad_covars + $$ ppr call) $ if interesting && isEmptyVarSet bad_covars then return (Just (CP { cp_qvars = qvars', cp_args = pats })) else return Nothing } @@ -2404,7 +2402,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 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2) + same e1 e2 = warnPprTrace (bad e1 || bad e2) (ppr e1 $$ ppr e2) $ False -- Let, lambda, case should not occur bad (Case {}) = True bad (Let {}) = True diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs index cab95b8b67..7a7eb5a5a3 100644 --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -10,8 +10,6 @@ module GHC.Core.Opt.Specialise ( specProgram, specUnfolding ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Driver.Session @@ -1440,8 +1438,8 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs foldlM spec_call ([], [], emptyUDs) calls_for_me | otherwise -- No calls or RHS doesn't fit our preconceptions - = WARN( not (exprIsTrivial rhs) && notNull calls_for_me, - text "Missed specialisation opportunity for" <+> ppr fn $$ _trace_doc ) + = warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me) + (text "Missed specialisation opportunity for" <+> ppr fn $$ _trace_doc) $ -- Note [Specialisation shape] -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $ return ([], [], emptyUDs) diff --git a/compiler/GHC/Core/Opt/StaticArgs.hs b/compiler/GHC/Core/Opt/StaticArgs.hs index ad82267523..00b84cdb2e 100644 --- a/compiler/GHC/Core/Opt/StaticArgs.hs +++ b/compiler/GHC/Core/Opt/StaticArgs.hs @@ -74,8 +74,6 @@ import GHC.Utils.Panic import Data.List (mapAccumL) import GHC.Data.FastString -#include "HsVersions.h" - doStaticArgs :: UniqSupply -> CoreProgram -> CoreProgram doStaticArgs us binds = snd $ mapAccumL sat_bind_threaded_us us binds where diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs index d27fdef24b..52c0b2259d 100644 --- a/compiler/GHC/Core/Opt/WorkWrap.hs +++ b/compiler/GHC/Core/Opt/WorkWrap.hs @@ -36,8 +36,6 @@ import GHC.Utils.Panic.Plain import GHC.Core.FamInstEnv import GHC.Utils.Monad -#include "HsVersions.h" - {- We take Core bindings whose binders have: @@ -636,7 +634,7 @@ See https://gitlab.haskell.org/ghc/ghc/merge_requests/312#note_192064. splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> Divergence -> Cpr -> CoreExpr -> UniqSM [(Id, CoreExpr)] splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs - = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr cpr) ) + = warnPprTrace (not (wrap_dmds `lengthIs` arity)) (ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr cpr)) $ -- The arity should match the signature do { mb_stuff <- mkWwBodies (initWwOpts dflags fam_envs) rhs_fvs fn_id wrap_dmds use_cpr_info ; case mb_stuff of diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs index ce8d901ee2..546fdd2fa2 100644 --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -16,8 +16,6 @@ module GHC.Core.Opt.WorkWrap.Utils ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Core @@ -230,9 +228,9 @@ mkWwBodies opts rhs_fvs fun_id demands cpr_info too_many_args_for_join_point wrap_args | Just join_arity <- mb_join_arity , wrap_args `lengthExceeds` join_arity - = WARN(True, text "Unable to worker/wrapper join point with arity " <+> + = warnPprTrace True (text "Unable to worker/wrapper join point with arity " <+> int join_arity <+> text "but" <+> - int (length wrap_args) <+> text "args") + int (length wrap_args) <+> text "args") $ True | otherwise = False @@ -503,7 +501,7 @@ mkWWargs subst fun_ty demands res_ty) } | otherwise - = WARN( True, ppr fun_ty ) -- Should not happen: if there is a demand + = warnPprTrace True (ppr fun_ty) $ -- Should not happen: if there is a demand return ([], nop_fn, nop_fn, substTy subst fun_ty) -- then there should be a function arrow where -- See Note [Join points and beta-redexes] @@ -671,7 +669,7 @@ wantToUnboxResult fam_envs ty cpr where -- | See Note [non-algebraic or open body type warning] - open_body_ty_warning = WARN( True, text "wantToUnboxResult: non-algebraic or open body type" <+> ppr ty ) Nothing + open_body_ty_warning = warnPprTrace True (text "wantToUnboxResult: non-algebraic or open body type" <+> ppr ty) Nothing isLinear :: Scaled a -> Bool isLinear (Scaled w _ ) = @@ -1025,7 +1023,7 @@ mk_absent_let opts arg -- Catch all: Either @arg_ty@ wasn't of form @TYPE rep@ or @rep@ wasn't mono rep. -- See (3) in Note [Absent fillers] | Nothing <- mb_mono_prim_reps - = WARN( True, text "No absent value for" <+> ppr arg_ty ) + = warnPprTrace True (text "No absent value for" <+> ppr arg_ty) $ Nothing where arg_ty = idType arg diff --git a/compiler/GHC/Core/PatSyn.hs b/compiler/GHC/Core/PatSyn.hs index 03daede521..49bd8039d0 100644 --- a/compiler/GHC/Core/PatSyn.hs +++ b/compiler/GHC/Core/PatSyn.hs @@ -23,8 +23,6 @@ module GHC.Core.PatSyn ( pprPatSynType ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Core.Type diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs index c61cdb8ee4..0b44b4f015 100644 --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -26,8 +26,6 @@ module GHC.Core.Rules ( lookupRule, mkRule, roughTopNames, initRuleOpts ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Core -- All of it diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index abf4a6c3a7..9bc41b8dfc 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -20,8 +20,6 @@ module GHC.Core.SimpleOpt ( ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Core diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs index 0f1305c52a..1d43387c72 100644 --- a/compiler/GHC/Core/Subst.hs +++ b/compiler/GHC/Core/Subst.hs @@ -34,9 +34,6 @@ module GHC.Core.Subst ( ) where -#include "HsVersions.h" - - import GHC.Prelude import GHC.Driver.Ppr @@ -257,8 +254,8 @@ lookupIdSubst (Subst in_scope ids _ _) v | Just e <- lookupVarEnv ids v = e | Just v' <- lookupInScope in_scope v = Var v' -- Vital! See Note [Extending the Subst] - | otherwise = WARN( True, text "GHC.Core.Subst.lookupIdSubst" <+> ppr v - $$ ppr in_scope) + | otherwise = warnPprTrace True (text "GHC.Core.Subst.lookupIdSubst" <+> ppr v + $$ ppr in_scope) $ Var v -- | Find the substitution for a 'TyVar' in the 'Subst' diff --git a/compiler/GHC/Core/Tidy.hs b/compiler/GHC/Core/Tidy.hs index 2cb8eb5471..eab1946051 100644 --- a/compiler/GHC/Core/Tidy.hs +++ b/compiler/GHC/Core/Tidy.hs @@ -13,8 +13,6 @@ module GHC.Core.Tidy ( tidyExpr, tidyRules, tidyUnfolding ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Core diff --git a/compiler/GHC/Core/TyCo/FVs.hs b/compiler/GHC/Core/TyCo/FVs.hs index 0cc06e0fa6..1c8dc4cadc 100644 --- a/compiler/GHC/Core/TyCo/FVs.hs +++ b/compiler/GHC/Core/TyCo/FVs.hs @@ -42,8 +42,6 @@ module GHC.Core.TyCo.FVs Endo(..), runTyCoVars ) where -#include "HsVersions.h" - import GHC.Prelude import {-# SOURCE #-} GHC.Core.Type (coreView, partitionInvisibleTypes) diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs index 19f1590c34..09bc9ab30d 100644 --- a/compiler/GHC/Core/TyCo/Rep.hs +++ b/compiler/GHC/Core/TyCo/Rep.hs @@ -74,8 +74,6 @@ module GHC.Core.TyCo.Rep ( Scaled(..), scaledMult, scaledThing, mapScaledType, Mult ) where -#include "HsVersions.h" - import GHC.Prelude import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprCo, pprTyLit ) diff --git a/compiler/GHC/Core/TyCo/Subst.hs b/compiler/GHC/Core/TyCo/Subst.hs index a741c6672a..42c6ddac59 100644 --- a/compiler/GHC/Core/TyCo/Subst.hs +++ b/compiler/GHC/Core/TyCo/Subst.hs @@ -52,8 +52,6 @@ module GHC.Core.TyCo.Subst checkValidSubst, isValidTCvSubst, ) where -#include "HsVersions.h" - import GHC.Prelude import {-# SOURCE #-} GHC.Core.Type diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs index a97efdf099..2a6bc4df4e 100644 --- a/compiler/GHC/Core/TyCon.hs +++ b/compiler/GHC/Core/TyCon.hs @@ -132,8 +132,6 @@ module GHC.Core.TyCon( ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Platform diff --git a/compiler/GHC/Core/TyCon/Env.hs b/compiler/GHC/Core/TyCon/Env.hs index d5947a2fda..bf2aaaf8c7 100644 --- a/compiler/GHC/Core/TyCon/Env.hs +++ b/compiler/GHC/Core/TyCon/Env.hs @@ -33,8 +33,6 @@ module GHC.Core.TyCon.Env ( adjustDTyConEnv, alterDTyConEnv, extendDTyConEnv, foldDTyConEnv ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Types.Unique.FM diff --git a/compiler/GHC/Core/TyCon/RecWalk.hs b/compiler/GHC/Core/TyCon/RecWalk.hs index 7ddb2eb4d2..a3c5c73cf4 100644 --- a/compiler/GHC/Core/TyCon/RecWalk.hs +++ b/compiler/GHC/Core/TyCon/RecWalk.hs @@ -16,8 +16,6 @@ module GHC.Core.TyCon.RecWalk ( ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Core.TyCon diff --git a/compiler/GHC/Core/TyCon/Set.hs b/compiler/GHC/Core/TyCon/Set.hs index d2615dfd73..567c52b43c 100644 --- a/compiler/GHC/Core/TyCon/Set.hs +++ b/compiler/GHC/Core/TyCon/Set.hs @@ -18,8 +18,6 @@ module GHC.Core.TyCon.Set ( nameSetAny, nameSetAll ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Types.Unique.Set diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index 9e5f05cde6..40c1e22149 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -235,8 +235,6 @@ module GHC.Core.Type ( isKindLevPoly ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Types.Basic diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs index 8de84d7a80..c4910e7974 100644 --- a/compiler/GHC/Core/Unfold.hs +++ b/compiler/GHC/Core/Unfold.hs @@ -37,8 +37,6 @@ module GHC.Core.Unfold ( calcUnfoldingGuidance ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Driver.Session diff --git a/compiler/GHC/Core/Unfold/Make.hs b/compiler/GHC/Core/Unfold/Make.hs index 513b246324..9cc5b030a0 100644 --- a/compiler/GHC/Core/Unfold/Make.hs +++ b/compiler/GHC/Core/Unfold/Make.hs @@ -19,8 +19,6 @@ module GHC.Core.Unfold.Make ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Core import GHC.Core.Unfold diff --git a/compiler/GHC/Core/Unify.hs b/compiler/GHC/Core/Unify.hs index bbdae319db..e7859f927b 100644 --- a/compiler/GHC/Core/Unify.hs +++ b/compiler/GHC/Core/Unify.hs @@ -27,8 +27,6 @@ module GHC.Core.Unify ( flattenTys, flattenTysX ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Types.Var diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index f63fc87e2a..b6273ed31d 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -66,8 +66,6 @@ module GHC.Core.Utils ( dumpIdInfoOfProgram ) where -#include "HsVersions.h" - import GHC.Prelude import GHC.Platform @@ -321,12 +319,12 @@ mkCast (Coercion e_co) co = Coercion (mkCoCast e_co co) mkCast (Cast expr co2) co - = WARN(let { from_ty = coercionLKind co; + = warnPprTrace (let { from_ty = coercionLKind co; to_ty2 = coercionRKind co2 } in - not (from_ty `eqType` to_ty2), - vcat ([ text "expr:" <+> ppr expr + not (from_ty `eqType` to_ty2)) + (vcat ([ text "expr:" <+> ppr expr , text "co2:" <+> ppr co2 - , text "co:" <+> ppr co ]) ) + , text "co:" <+> ppr co ])) $ mkCast expr (mkTransCo co2 co) mkCast (Tick t expr) co @@ -334,11 +332,11 @@ mkCast (Tick t expr) co mkCast expr co = let from_ty = coercionLKind co in - WARN( not (from_ty `eqType` exprType expr), - text "Trying to coerce" <+> text "(" <> ppr expr + warnPprTrace (not (from_ty `eqType` exprType expr)) + (text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ ppr (coercionType co) - $$ callStackDoc ) + $$ callStackDoc) $ (Cast expr co) -- | Wraps the given expression in the source annotation, dropping the |