Commit 03e44ee7 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Tidy up and refactor overflow checking for literals

It's much easier (and more efficient) to pattern match on
the HsOverLit than on the desugared version!
parent 62c40585
......@@ -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}
......@@ -825,103 +813,6 @@ mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++
\end{code}
%************************************************************************
%* *
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}
......
......@@ -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}
%************************************************************************
%* *
......
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