From 0656c72a8f4fda30c348bdf40449d105e4ce00ce Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Tue, 16 Nov 2010 17:15:10 +0000 Subject: [PATCH] Add warning for probable identities (fromIntegral and friends) See Trac #4488. The basic idea is to check for fun :: ty -> ty where fun is one of toIntegerName toRationalName fromIntegralName realToFracName There's a (documented) flag to control it -fwarn-identities. Currently -Wall switches it on. --- compiler/deSugar/Desugar.lhs | 10 +++++++--- compiler/deSugar/DsExpr.lhs | 40 +++++++++++++++++++++++++++++++++++++--- compiler/main/DynFlags.hs | 5 ++++- compiler/prelude/PrelNames.lhs | 28 +++++++++++++++++++++------- docs/users_guide/flags.xml | 8 ++++++++ docs/users_guide/using.xml | 15 +++++++++++++++ 6 files changed, 92 insertions(+), 14 deletions(-) diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index e5d763c..073e873 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -337,8 +337,9 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs)) = putSrcSpanDs loc $ do { let bndrs' = [var | RuleBndr (L _ var) <- vars] - ; lhs' <- unsetOptM Opt_EnableRewriteRules $ - dsLExpr lhs -- Note [Desugaring RULE left hand sides] + ; lhs' <- unsetOptM Opt_EnableRewriteRules $ + unsetOptM Opt_WarnIdentities $ + dsLExpr lhs -- Note [Desugaring RULE left hand sides] ; rhs' <- dsLExpr rhs @@ -359,6 +360,7 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs)) ; return (Just rule) } } } \end{code} + Note [Desugaring RULE left hand sides] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For the LHS of a RULE we do *not* want to desugar @@ -369,4 +371,6 @@ switching off EnableRewriteRules. See DsExpr.dsExplicitList. That keeps the desugaring of list comprehensions simple too. - +Nor do we want to warn of conversion identities on the LHS; +the rule is precisly to optimise them: + {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-} diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 5df12f5..e79ce7f 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -222,9 +222,13 @@ dsExpr (HsVar var) = return (Var var) dsExpr (HsIPVar ip) = return (Var (ipNameName ip)) dsExpr (HsLit lit) = dsLit lit dsExpr (HsOverLit lit) = dsOverLit lit -dsExpr (HsWrap co_fn e) = do { co_fn' <- dsHsWrapper co_fn - ; e' <- dsExpr e - ; return (co_fn' e') } + +dsExpr (HsWrap co_fn e) + = do { co_fn' <- dsHsWrapper co_fn + ; e' <- dsExpr e + ; warn_id <- doptDs Opt_WarnIdentities + ; when warn_id $ warnAboutIdentities e' co_fn' + ; return (co_fn' e') } dsExpr (NegApp expr neg_expr) = App <$> dsExpr neg_expr <*> dsLExpr expr @@ -891,6 +895,36 @@ dsMDo ctxt tbl stmts body result_ty %************************************************************************ %* * + Warning about identities +%* * +%************************************************************************ + +Warn about functions that convert between one type and another +when the to- and from- types are the same. Then it's probably +(albeit not definitely) the identity +\begin{code} +warnAboutIdentities :: CoreExpr -> (CoreExpr -> CoreExpr) -> DsM () +warnAboutIdentities (Var v) co_fn + | idName v `elem` conversionNames + , let fun_ty = exprType (co_fn (Var v)) + , Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty + , arg_ty `tcEqType` res_ty -- So we are converting ty -> ty + = warnDs (vcat [ ptext (sLit "Call of") <+> ppr v <+> dcolon <+> ppr fun_ty + , nest 2 $ ptext (sLit "can probably be omitted") + , parens (ptext (sLit "Use -fno-warn-identities to suppress this messsage)")) + ]) +warnAboutIdentities _ _ = return () + +conversionNames :: [Name] +conversionNames + = [ toIntegerName, toRationalName + , fromIntegralName, realToFracName ] + -- We can't easily add fromIntegerName, fromRationalName, + -- becuase they are generated by literals +\end{code} + +%************************************************************************ +%* * \subsection{Errors and contexts} %* * %************************************************************************ diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 00eb543..513c97f 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -199,6 +199,7 @@ data DynFlag | Opt_WarnDodgyImports | Opt_WarnOrphans | Opt_WarnAutoOrphans + | Opt_WarnIdentities | Opt_WarnTabs | Opt_WarnUnrecognisedPragmas | Opt_WarnDodgyForeignImports @@ -1422,6 +1423,7 @@ fFlags = [ ( "warn-deprecations", Opt_WarnWarningsDeprecations, nop ), ( "warn-deprecated-flags", Opt_WarnDeprecatedFlags, nop ), ( "warn-orphans", Opt_WarnOrphans, nop ), + ( "warn-identities", Opt_WarnIdentities, nop ), ( "warn-auto-orphans", Opt_WarnAutoOrphans, nop ), ( "warn-tabs", Opt_WarnTabs, nop ), ( "warn-unrecognised-pragmas", Opt_WarnUnrecognisedPragmas, nop ), @@ -1735,7 +1737,8 @@ minusWallOpts Opt_WarnMissingSigs, Opt_WarnHiShadows, Opt_WarnOrphans, - Opt_WarnUnusedDoBind + Opt_WarnUnusedDoBind, + Opt_WarnIdentities ] -- minuswRemovesOpts should be every warning option diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index e2e2dfe..40910f6 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -136,9 +136,12 @@ basicKnownKeyNames traversableClassName, -- Numeric stuff - negateName, minusName, - fromRationalName, fromIntegerName, - geName, eqName, + negateName, minusName, geName, eqName, + + -- Conversion functions + fromRationalName, fromIntegerName, + toIntegerName, toRationalName, + fromIntegralName, realToFracName, -- String stuff fromStringName, @@ -639,7 +642,7 @@ fstName, sndName :: Name fstName = varQual dATA_TUPLE (fsLit "fst") fstIdKey sndName = varQual dATA_TUPLE (fsLit "snd") sndIdKey --- Module PrelNum +-- Module GHC.Num numClassName, fromIntegerName, minusName, negateName, plusIntegerName, timesIntegerName, integerTyConName, smallIntegerName :: Name @@ -652,10 +655,11 @@ timesIntegerName = varQual gHC_INTEGER (fsLit "timesInteger") timesIntegerIdKe integerTyConName = tcQual gHC_INTEGER_TYPE (fsLit "Integer") integerTyConKey smallIntegerName = varQual gHC_INTEGER (fsLit "smallInteger") smallIntegerIdKey --- PrelReal types and classes +-- GHC.Real types and classes rationalTyConName, ratioTyConName, ratioDataConName, realClassName, integralClassName, realFracClassName, fractionalClassName, - fromRationalName :: Name + fromRationalName, toIntegerName, toRationalName, fromIntegralName, + realToFracName :: Name rationalTyConName = tcQual gHC_REAL (fsLit "Rational") rationalTyConKey ratioTyConName = tcQual gHC_REAL (fsLit "Ratio") ratioTyConKey ratioDataConName = conName gHC_REAL (fsLit ":%") ratioDataConKey @@ -663,7 +667,11 @@ realClassName = clsQual gHC_REAL (fsLit "Real") realClassKey integralClassName = clsQual gHC_REAL (fsLit "Integral") integralClassKey realFracClassName = clsQual gHC_REAL (fsLit "RealFrac") realFracClassKey fractionalClassName = clsQual gHC_REAL (fsLit "Fractional") fractionalClassKey -fromRationalName = methName gHC_REAL (fsLit "fromRational") fromRationalClassOpKey +fromRationalName = methName gHC_REAL (fsLit "fromRational") fromRationalClassOpKey +toIntegerName = methName gHC_REAL (fsLit "toInteger") toIntegerClassOpKey +toRationalName = methName gHC_REAL (fsLit "toRational") toRationalClassOpKey +fromIntegralName = varQual gHC_REAL (fsLit "fromIntegral") fromIntegralIdKey +realToFracName = varQual gHC_REAL (fsLit "realToFrac") realToFracIdKey -- PrelFloat classes floatingClassName, realFloatClassName :: Name @@ -1286,6 +1294,12 @@ fromStringClassOpKey = mkPreludeMiscIdUnique 125 toAnnotationWrapperIdKey :: Unique toAnnotationWrapperIdKey = mkPreludeMiscIdUnique 126 +-- Conversion functions +fromIntegralIdKey, realToFracIdKey, toIntegerClassOpKey, toRationalClassOpKey :: Unique +fromIntegralIdKey = mkPreludeMiscIdUnique 127 +realToFracIdKey = mkPreludeMiscIdUnique 128 +toIntegerClassOpKey = mkPreludeMiscIdUnique 129 +toRationalClassOpKey = mkPreludeMiscIdUnique 130 ---------------- Template Haskell ------------------- -- USES IdUniques 200-399 diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index 8482a7c..c24d021 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -1114,6 +1114,14 @@ + + warn about uses of Prelude numeric conversions that are probably + the identity (and hence could be omitted) + dynamic + + + + warn when the Prelude is implicitly imported dynamic diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml index be82322..22c8861 100644 --- a/docs/users_guide/using.xml +++ b/docs/users_guide/using.xml @@ -1175,6 +1175,21 @@ foreign import "&f" f :: FunPtr t + : + + + Causes the compiler to emit a warning when a Prelude numeric + conversion converts a type T to the same type T; such calls + are probably no-ops and can be omitted. The functions checked for + are: toInteger, + toRational, + fromIntegral, + and realToFrac. + + + + + : -- 1.7.10.4