diff options
| -rw-r--r-- | compiler/deSugar/DsExpr.lhs | 127 | ||||
| -rw-r--r-- | compiler/deSugar/MatchLit.lhs | 175 |
2 files changed, 153 insertions, 149 deletions
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 6945cf38e0..3a8815a603 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -48,21 +48,14 @@ import VarEnv import DataCon import TysWiredIn import BasicTypes -import PrelNames import Maybes import SrcLoc import Util import Bag import Outputable -import Literal -import TyCon import FastString import Control.Monad -import Data.Int -import Data.Traversable (traverse) -import Data.Typeable (typeOf) -import Data.Word \end{code} @@ -201,8 +194,8 @@ dsExpr (HsOverLit lit) = dsOverLit lit dsExpr (HsWrap co_fn e) = do { e' <- dsExpr e ; wrapped_e <- dsHsWrapper co_fn e' - ; warn_id <- woptM Opt_WarnIdentities - ; when warn_id $ warnAboutIdentities e' wrapped_e + ; dflags <- getDynFlags + ; warnAboutIdentities dflags e' (exprType wrapped_e) ; return wrapped_e } dsExpr (NegApp expr neg_expr) @@ -217,10 +210,7 @@ dsExpr (HsLamCase arg matches) ; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code } dsExpr (HsApp fun arg) - = do ds <- mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg - warn_overflowed_literals <- woptM Opt_WarnOverflowedLiterals - when warn_overflowed_literals $ warnAboutOverflowedLiterals ds - return ds + = mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg dsExpr (HsUnboundVar _) = panic "dsExpr: HsUnboundVar" \end{code} @@ -719,23 +709,21 @@ dsArithSeq :: PostTcExpr -> (ArithSeqInfo Id) -> DsM CoreExpr dsArithSeq expr (From from) = App <$> dsExpr expr <*> dsLExpr from dsArithSeq expr (FromTo from to) - = do expr' <- dsExpr expr + = do dflags <- getDynFlags + warnAboutEmptyEnumerations dflags from Nothing to + expr' <- dsExpr expr from' <- dsLExpr from to' <- dsLExpr to - warn_empty_enumerations <- woptM Opt_WarnEmptyEnumerations - when warn_empty_enumerations $ - warnAboutEmptyEnumerations from' Nothing to' return $ mkApps expr' [from', to'] dsArithSeq expr (FromThen from thn) = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn] dsArithSeq expr (FromThenTo from thn to) - = do expr' <- dsExpr expr + = do dflags <- getDynFlags + warnAboutEmptyEnumerations dflags from (Just thn) to + expr' <- dsExpr expr from' <- dsLExpr from thn' <- dsLExpr thn to' <- dsLExpr to - warn_empty_enumerations <- woptM Opt_WarnEmptyEnumerations - when warn_empty_enumerations $ - warnAboutEmptyEnumerations from' (Just thn') to' return $ mkApps expr' [from', thn', to'] \end{code} @@ -827,103 +815,6 @@ mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++ %************************************************************************ %* * - Warnings -%* * -%************************************************************************ - -Warn about functions like toInteger, fromIntegral, 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 -> DsM () -warnAboutIdentities (Var v) wrapped_fun - | idName v `elem` conversionNames - , let fun_ty = exprType wrapped_fun - , Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty - , arg_ty `eqType` 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, - -- because they are generated by literals -\end{code} - -\begin{code} -warnAboutOverflowedLiterals :: CoreExpr -> DsM () -warnAboutOverflowedLiterals (App (App (App (Var f) (Type t)) _) (Lit (LitInteger i _))) - | idName f == fromIntegerName, - Just tc <- tyConAppTyCon_maybe t, - let t = tyConName tc - = let checkOverflow proxy - = when (i < fromIntegral (minBound `asTypeOf` proxy) || - i > fromIntegral (maxBound `asTypeOf` proxy)) $ - warnDs (ptext (sLit "Literal") <+> integer i <+> - ptext (sLit "of type") <+> - text (show (typeOf proxy)) <+> - ptext (sLit "overflows")) - in if t == intTyConName then checkOverflow (undefined :: Int) - else if t == int8TyConName then checkOverflow (undefined :: Int8) - else if t == int16TyConName then checkOverflow (undefined :: Int16) - else if t == int32TyConName then checkOverflow (undefined :: Int32) - else if t == int64TyConName then checkOverflow (undefined :: Int64) - else if t == wordTyConName then checkOverflow (undefined :: Word) - else if t == word8TyConName then checkOverflow (undefined :: Word8) - else if t == word16TyConName then checkOverflow (undefined :: Word16) - else if t == word32TyConName then checkOverflow (undefined :: Word32) - else if t == word64TyConName then checkOverflow (undefined :: Word64) - else return () -warnAboutOverflowedLiterals _ = return () -\end{code} - -\begin{code} -warnAboutEmptyEnumerations :: CoreExpr -> Maybe CoreExpr -> CoreExpr -> DsM () -warnAboutEmptyEnumerations fromExpr mThnExpr toExpr - | Just from <- getVal fromExpr - , Just mThn <- traverse getVal mThnExpr - , Just to <- getVal toExpr - , Just t <- getType fromExpr - = let check proxy - = let enumeration - = case mThn of - Nothing -> [(fromInteger from `asTypeOf` proxy) .. fromInteger to] - Just thn -> [fromInteger from, fromInteger thn .. fromInteger to] - in when (null enumeration) $ - warnDs (ptext (sLit "Enumeration is empty")) - - in if t == intTyConName then check (undefined :: Int) - else if t == int8TyConName then check (undefined :: Int8) - else if t == int16TyConName then check (undefined :: Int16) - else if t == int32TyConName then check (undefined :: Int32) - else if t == int64TyConName then check (undefined :: Int64) - else if t == wordTyConName then check (undefined :: Word) - else if t == word8TyConName then check (undefined :: Word8) - else if t == word16TyConName then check (undefined :: Word16) - else if t == word32TyConName then check (undefined :: Word32) - else if t == word64TyConName then check (undefined :: Word64) - else return () - - where getVal (App (App (App (Var f) (Type _)) _) (Lit (LitInteger i _))) - | idName f == fromIntegerName = Just i - getVal _ = Nothing - - getType (App (App (App (Var f) (Type t)) _) (Lit (LitInteger _ _))) - | idName f == fromIntegerName, - Just tc <- tyConAppTyCon_maybe t = Just (tyConName tc) - getType _ = Nothing - -warnAboutEmptyEnumerations _ _ _ = return () -\end{code} - -%************************************************************************ -%* * \subsection{Errors and contexts} %* * %************************************************************************ diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs index 23538bec82..d79cfcc30f 100644 --- a/compiler/deSugar/MatchLit.lhs +++ b/compiler/deSugar/MatchLit.lhs @@ -6,9 +6,11 @@ Pattern-matching literal patterns \begin{code} -module MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey, - tidyLitPat, tidyNPat, - matchLiterals, matchNPlusKPats, matchNPats ) where +module MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey + , tidyLitPat, tidyNPat + , matchLiterals, matchNPlusKPats, matchNPats + , warnAboutIdentities, warnAboutEmptyEnumerations + ) where #include "HsVersions.h" @@ -27,6 +29,8 @@ import TyCon import DataCon import TcHsSyn ( shortCutLit ) import TcType +import Name +import Type import PrelNames import TysWiredIn import Literal @@ -38,6 +42,11 @@ import BasicTypes import DynFlags import Util import FastString +import Control.Monad + +import Data.Int +import Data.Traversable (traverse) +import Data.Word \end{code} %************************************************************************ @@ -90,8 +99,9 @@ dsLit (HsRat r ty) = do x -> pprPanic "dsLit" (ppr x) dsOverLit :: HsOverLit Id -> DsM CoreExpr -dsOverLit lit = do dflags <- getDynFlags - dsOverLit' dflags lit +dsOverLit lit = do { dflags <- getDynFlags + ; warnAboutOverflowedLiterals dflags lit + ; dsOverLit' dflags lit } dsOverLit' :: DynFlags -> HsOverLit Id -> DsM CoreExpr -- Post-typechecker, the SyntaxExpr field of an OverLit contains @@ -111,36 +121,109 @@ And where it's possible to generate the correct literal right away, it's much better to do so. +%************************************************************************ +%* * + Warnings about overflowed literals +%* * +%************************************************************************ + +Warn about functions like toInteger, fromIntegral, 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} -hsLitKey :: DynFlags -> HsLit -> Literal --- Get a Core literal to use (only) a grouping key --- Hence its type doesn't need to match the type of the original literal --- (and doesn't for strings) --- It only works for primitive types and strings; --- others have been removed by tidy -hsLitKey dflags (HsIntPrim i) = mkMachInt dflags i -hsLitKey dflags (HsWordPrim w) = mkMachWord dflags w -hsLitKey _ (HsInt64Prim i) = mkMachInt64 i -hsLitKey _ (HsWord64Prim w) = mkMachWord64 w -hsLitKey _ (HsCharPrim c) = MachChar c -hsLitKey _ (HsStringPrim s) = MachStr s -hsLitKey _ (HsFloatPrim f) = MachFloat (fl_value f) -hsLitKey _ (HsDoublePrim d) = MachDouble (fl_value d) -hsLitKey _ (HsString s) = MachStr (fastStringToByteString s) -hsLitKey _ l = pprPanic "hsLitKey" (ppr l) +warnAboutIdentities :: DynFlags -> CoreExpr -> Type -> DsM () +warnAboutIdentities dflags (Var conv_fn) type_of_conv + | wopt Opt_WarnIdentities dflags + , idName conv_fn `elem` conversionNames + , Just (arg_ty, res_ty) <- splitFunTy_maybe type_of_conv + , arg_ty `eqType` res_ty -- So we are converting ty -> ty + = warnDs (vcat [ ptext (sLit "Call of") <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv + , 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, + -- because they are generated by literals +\end{code} -hsOverLitKey :: OutputableBndr a => HsOverLit a -> Bool -> Literal --- Ditto for HsOverLit; the boolean indicates to negate -hsOverLitKey (OverLit { ol_val = l }) neg = litValKey l neg +\begin{code} +warnAboutOverflowedLiterals :: DynFlags -> HsOverLit Id -> DsM () +warnAboutOverflowedLiterals dflags lit + | wopt Opt_WarnOverflowedLiterals dflags + , Just (i, tc) <- getIntegralLit lit + , let check :: forall a. (Bounded a, Integral a) => a -> DsM () + check _proxy + = when (i < toInteger (minBound :: a) || + i > toInteger (maxBound :: a)) $ + warnDs (ptext (sLit "Literal") <+> integer i <+> + ptext (sLit "of type") <+> ppr tc <+> + ptext (sLit "overflows")) + = if tc == intTyConName then check (undefined :: Int) + else if tc == int8TyConName then check (undefined :: Int8) + else if tc == int16TyConName then check (undefined :: Int16) + else if tc == int32TyConName then check (undefined :: Int32) + else if tc == int64TyConName then check (undefined :: Int64) + else if tc == wordTyConName then check (undefined :: Word) + else if tc == word8TyConName then check (undefined :: Word8) + else if tc == word16TyConName then check (undefined :: Word16) + else if tc == word32TyConName then check (undefined :: Word32) + else if tc == word64TyConName then check (undefined :: Word64) + else return () + + | otherwise = return () +\end{code} -litValKey :: OverLitVal -> Bool -> Literal -litValKey (HsIntegral i) False = MachInt i -litValKey (HsIntegral i) True = MachInt (-i) -litValKey (HsFractional r) False = MachFloat (fl_value r) -litValKey (HsFractional r) True = MachFloat (negate (fl_value r)) -litValKey (HsIsString s) neg = ASSERT( not neg) MachStr (fastStringToByteString s) +\begin{code} +warnAboutEmptyEnumerations :: DynFlags -> LHsExpr Id -> Maybe (LHsExpr Id) -> LHsExpr Id -> DsM () +-- Warns about [2,3 .. 1] which returns the empty list +-- Only works for integral types, not floating point +warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr + | wopt Opt_WarnEmptyEnumerations dflags + , Just (from,tc) <- getLHsIntegralLit fromExpr + , Just mThn <- traverse getLHsIntegralLit mThnExpr + , Just (to,_) <- getLHsIntegralLit toExpr + , let check :: forall a. (Enum a, Num a) => a -> DsM () + check _proxy + = when (null enumeration) $ + warnDs (ptext (sLit "Enumeration is empty")) + where + enumeration :: [a] + enumeration = case mThn of + Nothing -> [fromInteger from .. fromInteger to] + Just (thn,_) -> [fromInteger from, fromInteger thn .. fromInteger to] + + = if tc == intTyConName then check (undefined :: Int) + else if tc == int8TyConName then check (undefined :: Int8) + else if tc == int16TyConName then check (undefined :: Int16) + else if tc == int32TyConName then check (undefined :: Int32) + else if tc == int64TyConName then check (undefined :: Int64) + else if tc == wordTyConName then check (undefined :: Word) + else if tc == word8TyConName then check (undefined :: Word8) + else if tc == word16TyConName then check (undefined :: Word16) + else if tc == word32TyConName then check (undefined :: Word32) + else if tc == word64TyConName then check (undefined :: Word64) + else return () + + | otherwise = return () + +getLHsIntegralLit :: LHsExpr Id -> Maybe (Integer, Name) +getLHsIntegralLit (L _ (HsOverLit over_lit)) = getIntegralLit over_lit +getLHsIntegralLit _ = Nothing + +getIntegralLit :: HsOverLit Id -> Maybe (Integer, Name) +getIntegralLit (OverLit { ol_val = HsIntegral i, ol_type = ty }) + | Just tc <- tyConAppTyCon_maybe ty + = Just (i, tyConName tc) +getIntegralLit _ = Nothing \end{code} + %************************************************************************ %* * Tidying lit pats @@ -263,8 +346,38 @@ matchLiterals (var:vars) ty sub_groups wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l) matchLiterals [] _ _ = panic "matchLiterals []" -\end{code} +--------------------------- +hsLitKey :: DynFlags -> HsLit -> Literal +-- Get a Core literal to use (only) a grouping key +-- Hence its type doesn't need to match the type of the original literal +-- (and doesn't for strings) +-- It only works for primitive types and strings; +-- others have been removed by tidy +hsLitKey dflags (HsIntPrim i) = mkMachInt dflags i +hsLitKey dflags (HsWordPrim w) = mkMachWord dflags w +hsLitKey _ (HsInt64Prim i) = mkMachInt64 i +hsLitKey _ (HsWord64Prim w) = mkMachWord64 w +hsLitKey _ (HsCharPrim c) = MachChar c +hsLitKey _ (HsStringPrim s) = MachStr s +hsLitKey _ (HsFloatPrim f) = MachFloat (fl_value f) +hsLitKey _ (HsDoublePrim d) = MachDouble (fl_value d) +hsLitKey _ (HsString s) = MachStr (fastStringToByteString s) +hsLitKey _ l = pprPanic "hsLitKey" (ppr l) + +--------------------------- +hsOverLitKey :: OutputableBndr a => HsOverLit a -> Bool -> Literal +-- Ditto for HsOverLit; the boolean indicates to negate +hsOverLitKey (OverLit { ol_val = l }) neg = litValKey l neg + +--------------------------- +litValKey :: OverLitVal -> Bool -> Literal +litValKey (HsIntegral i) False = MachInt i +litValKey (HsIntegral i) True = MachInt (-i) +litValKey (HsFractional r) False = MachFloat (fl_value r) +litValKey (HsFractional r) True = MachFloat (negate (fl_value r)) +litValKey (HsIsString s) neg = ASSERT( not neg) MachStr (fastStringToByteString s) +\end{code} %************************************************************************ %* * |