Skip to content

Commit

Permalink
Make XNegativeLiterals treat -0.0 as negative 0
Browse files Browse the repository at this point in the history 
Reviewers: austin, goldfire, bgamari

Reviewed By: bgamari

Subscribers: rwbarton, thomie, mpickering

GHC Trac Issues: #13211

Differential Revision: https://phabricator.haskell.org/D3543
  • Loading branch information
@NolanDeveloper @bgamari
NolanDeveloper authored and bgamari committed May 8, 2017
1 parent dc3b4af commit 0279b74
Show file tree
Hide file tree
Showing 22 changed files with 260 additions and 122 deletions.
62 changes: 55 additions & 7 deletions compiler/basicTypes/BasicTypes.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -97,7 +97,10 @@ module BasicTypes(

SuccessFlag(..), succeeded, failed, successIf,

FractionalLit(..), negateFractionalLit, integralFractionalLit,
IntegralLit(..), FractionalLit(..),
negateIntegralLit, negateFractionalLit,
mkIntegralLit, mkFractionalLit,
integralFractionalLit,

SourceText(..), pprWithSourceText,

Expand Down Expand Up @@ -1404,37 +1407,82 @@ isEarlyActive AlwaysActive = True
isEarlyActive (ActiveBefore {}) = True
isEarlyActive _ = False

-- | Integral Literal
--
-- Used (instead of Integer) to represent negative zegative zero which is
-- required for NegativeLiterals extension to correctly parse `-0::Double`
-- as negative zero. See also #13211.
data IntegralLit
= IL { il_text :: SourceText
, il_neg :: Bool -- See Note [Negative zero]
, il_value :: Integer
}
deriving (Data, Show)

mkIntegralLit :: Integral a => a -> IntegralLit
mkIntegralLit i = IL { il_text = SourceText (show (fromIntegral i :: Int))
, il_neg = i < 0
, il_value = toInteger i }

negateIntegralLit :: IntegralLit -> IntegralLit
negateIntegralLit (IL text neg value)
= case text of
SourceText ('-':src) -> IL (SourceText src) False (negate value)
SourceText src -> IL (SourceText ('-':src)) True (negate value)
NoSourceText -> IL NoSourceText (not neg) (negate value)

-- | Fractional Literal
--
-- Used (instead of Rational) to represent exactly the floating point literal that we
-- encountered in the user's source program. This allows us to pretty-print exactly what
-- the user wrote, which is important e.g. for floating point numbers that can't represented
-- as Doubles (we used to via Double for pretty-printing). See also #2245.
data FractionalLit
= FL { fl_text :: String -- How the value was written in the source
= FL { fl_text :: SourceText -- How the value was written in the source
, fl_neg :: Bool -- See Note [Negative zero]
, fl_value :: Rational -- Numeric value of the literal
}
deriving (Data, Show)
-- The Show instance is required for the derived Lexer.x:Token instance when DEBUG is on

mkFractionalLit :: Real a => a -> FractionalLit
mkFractionalLit r = FL { fl_text = SourceText (show (realToFrac r::Double))
, fl_neg = r < 0
, fl_value = toRational r }

negateFractionalLit :: FractionalLit -> FractionalLit
negateFractionalLit (FL { fl_text = '-':text, fl_value = value }) = FL { fl_text = text, fl_value = negate value }
negateFractionalLit (FL { fl_text = text, fl_value = value }) = FL { fl_text = '-':text, fl_value = negate value }
negateFractionalLit (FL text neg value)
= case text of
SourceText ('-':src) -> FL (SourceText src) False value
SourceText src -> FL (SourceText ('-':src)) True value
NoSourceText -> FL NoSourceText (not neg) (negate value)

integralFractionalLit :: Integer -> FractionalLit
integralFractionalLit i = FL { fl_text = show i, fl_value = fromInteger i }
integralFractionalLit :: Bool -> Integer -> FractionalLit
integralFractionalLit neg i = FL { fl_text = SourceText (show i),
fl_neg = neg,
fl_value = fromInteger i }

-- Comparison operations are needed when grouping literals
-- for compiling pattern-matching (module MatchLit)

instance Eq IntegralLit where
(==) = (==) `on` il_value

instance Ord IntegralLit where
compare = compare `on` il_value

instance Outputable IntegralLit where
ppr (IL (SourceText src) _ _) = text src
ppr (IL NoSourceText _ value) = text (show value)

instance Eq FractionalLit where
(==) = (==) `on` fl_value

instance Ord FractionalLit where
compare = compare `on` fl_value

instance Outputable FractionalLit where
ppr = text . fl_text
ppr f = pprWithSourceText (fl_text f) (rational (fl_value f))

{-
************************************************************************
Expand Down
20 changes: 13 additions & 7 deletions compiler/deSugar/Check.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -19,6 +19,7 @@ module Check (

import TmOracle

import BasicTypes
import DynFlags
import HsSyn
import TcHsSyn
Expand Down Expand Up @@ -668,15 +669,20 @@ translateNPat :: FamInstEnvs
translateNPat fam_insts (OverLit val False _ ty) mb_neg outer_ty
| not type_change, isStringTy ty, HsIsString src s <- val, Nothing <- mb_neg
= translatePat fam_insts (LitPat (HsString src s))
| not type_change, isIntTy ty, HsIntegral src i <- val
= translatePat fam_insts (mk_num_lit HsInt src i)
| not type_change, isWordTy ty, HsIntegral src i <- val
= translatePat fam_insts (mk_num_lit HsWordPrim src i)
| not type_change, isIntTy ty, HsIntegral i <- val
= translatePat fam_insts
(LitPat $ case mb_neg of
Nothing -> HsInt i
Just _ -> HsInt (negateIntegralLit i))
| not type_change, isWordTy ty, HsIntegral i <- val
= translatePat fam_insts
(LitPat $ case mb_neg of
Nothing -> HsWordPrim (il_text i) (il_value i)
Just _ -> let ni = negateIntegralLit i in
HsWordPrim (il_text ni) (il_value ni))
where
type_change = not (outer_ty `eqType` ty)
mk_num_lit c src i = LitPat $ case mb_neg of
Nothing -> c src i
Just _ -> c src (-i)

translateNPat _ ol mb_neg _
= return [PmLit { pm_lit_lit = PmOLit (isJust mb_neg) ol }]

Expand Down
4 changes: 2 additions & 2 deletions compiler/deSugar/DsExpr.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -277,12 +277,12 @@ ds_expr _ (HsWrap co_fn e)
; warnAboutIdentities dflags e' wrapped_ty
; return wrapped_e }

ds_expr _ (NegApp (L loc (HsOverLit lit@(OverLit { ol_val = HsIntegral src i })))
ds_expr _ (NegApp (L loc (HsOverLit lit@(OverLit { ol_val = HsIntegral i })))
neg_expr)
= do { expr' <- putSrcSpanDs loc $ do
{ dflags <- getDynFlags
; warnAboutOverflowedLiterals dflags
(lit { ol_val = HsIntegral src (-i) })
(lit { ol_val = HsIntegral (negateIntegralLit i) })
; dsOverLit' dflags lit }
; dsSyntaxExpr neg_expr [expr'] }

Expand Down
7 changes: 4 additions & 3 deletions compiler/deSugar/DsMeta.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2371,7 +2371,7 @@ repLiteral lit
= do lit' <- case lit of
HsIntPrim _ i -> mk_integer i
HsWordPrim _ w -> mk_integer w
HsInt _ i -> mk_integer i
HsInt i -> mk_integer (il_value i)
HsFloatPrim r -> mk_rational r
HsDoublePrim r -> mk_rational r
HsCharPrim _ c -> mk_char c
Expand All @@ -2383,7 +2383,7 @@ repLiteral lit
where
mb_lit_name = case lit of
HsInteger _ _ _ -> Just integerLName
HsInt _ _ -> Just integerLName
HsInt _ -> Just integerLName
HsIntPrim _ _ -> Just intPrimLName
HsWordPrim _ _ -> Just wordPrimLName
HsFloatPrim _ -> Just floatPrimLName
Expand All @@ -2397,6 +2397,7 @@ repLiteral lit
mk_integer :: Integer -> DsM HsLit
mk_integer i = do integer_ty <- lookupType integerTyConName
return $ HsInteger NoSourceText i integer_ty

mk_rational :: FractionalLit -> DsM HsLit
mk_rational r = do rat_ty <- lookupType rationalTyConName
return $ HsRat r rat_ty
Expand All @@ -2414,7 +2415,7 @@ repOverloadedLiteral (OverLit { ol_val = val})
-- and rationalL is sucked in when any TH stuff is used

mk_lit :: OverLitVal -> DsM HsLit
mk_lit (HsIntegral _ i) = mk_integer i
mk_lit (HsIntegral i) = mk_integer (il_value i)
mk_lit (HsFractional f) = mk_rational f
mk_lit (HsIsString _ s) = mk_string s

Expand Down
8 changes: 4 additions & 4 deletions compiler/deSugar/Match.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -44,7 +44,7 @@ import Maybes
import Util
import Name
import Outputable
import BasicTypes ( isGenerated, fl_value )
import BasicTypes ( isGenerated, il_value, fl_value )
import FastString
import Unique
import UniqDFM
Expand Down Expand Up @@ -1093,15 +1093,15 @@ patGroup _ (WildPat {}) = PgAny
patGroup _ (BangPat {}) = PgBang
patGroup _ (NPat (L _ OverLit {ol_val=oval}) mb_neg _ _) =
case (oval, isJust mb_neg) of
(HsIntegral _ i, False) -> PgN (fromInteger i)
(HsIntegral _ i, True ) -> PgN (-fromInteger i)
(HsIntegral i, False) -> PgN (fromInteger (il_value i))
(HsIntegral i, True ) -> PgN (-fromInteger (il_value i))
(HsFractional r, False) -> PgN (fl_value r)
(HsFractional r, True ) -> PgN (-fl_value r)
(HsIsString _ s, _) -> ASSERT(isNothing mb_neg)
PgOverS s
patGroup _ (NPlusKPat _ (L _ OverLit {ol_val=oval}) _ _ _ _) =
case oval of
HsIntegral _ i -> PgNpK i
HsIntegral i -> PgNpK (il_value i)
_ -> pprPanic "patGroup NPlusKPat" (ppr oval)
patGroup _ (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern
patGroup _ (ViewPat expr p _) = PgView expr (hsPatType (unLoc p))
Expand Down
21 changes: 10 additions & 11 deletions compiler/deSugar/MatchLit.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -82,17 +82,16 @@ dsLit (HsInt64Prim _ i) = return (Lit (MachInt64 i))
dsLit (HsWord64Prim _ w) = return (Lit (MachWord64 w))
dsLit (HsFloatPrim f) = return (Lit (MachFloat (fl_value f)))
dsLit (HsDoublePrim d) = return (Lit (MachDouble (fl_value d)))

dsLit (HsChar _ c) = return (mkCharExpr c)
dsLit (HsString _ str) = mkStringExprFS str
dsLit (HsInteger _ i _) = mkIntegerExpr i
dsLit (HsInt _ i) = do dflags <- getDynFlags
return (mkIntExpr dflags i)
dsLit (HsInt i) = do dflags <- getDynFlags
return (mkIntExpr dflags (il_value i))

dsLit (HsRat r ty) = do
num <- mkIntegerExpr (numerator (fl_value r))
denom <- mkIntegerExpr (denominator (fl_value r))
return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
dsLit (HsRat (FL _ _ val) ty) = do
num <- mkIntegerExpr (numerator val)
denom <- mkIntegerExpr (denominator val)
return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
where
(ratio_data_con, integer_ty)
= case tcSplitTyConApp ty of
Expand Down Expand Up @@ -243,9 +242,9 @@ 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 })
getIntegralLit (OverLit { ol_val = HsIntegral i, ol_type = ty })
| Just tc <- tyConAppTyCon_maybe ty
= Just (i, tyConName tc)
= Just (il_value i, tyConName tc)
getIntegralLit _ = Nothing

{-
Expand Down Expand Up @@ -313,8 +312,8 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty

mb_int_lit :: Maybe Integer
mb_int_lit = case (mb_neg, val) of
(Nothing, HsIntegral _ i) -> Just i
(Just _, HsIntegral _ i) -> Just (-i)
(Nothing, HsIntegral i) -> Just (il_value i)
(Just _, HsIntegral i) -> Just (-(il_value i))
_ -> Nothing

mb_str_lit :: Maybe FastString
Expand Down
11 changes: 4 additions & 7 deletions compiler/hsSyn/Convert.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1007,9 +1007,9 @@ cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs

cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
cvtOverLit (IntegerL i)
= do { force i; return $ mkHsIntegral NoSourceText i placeHolderType}
= do { force i; return $ mkHsIntegral (mkIntegralLit i) placeHolderType}
cvtOverLit (RationalL r)
= do { force r; return $ mkHsFractional (cvtFractionalLit r) placeHolderType}
= do { force r; return $ mkHsFractional (mkFractionalLit r) placeHolderType}
cvtOverLit (StringL s)
= do { let { s' = mkFastString s }
; force s'
Expand Down Expand Up @@ -1043,8 +1043,8 @@ allCharLs xs
cvtLit :: Lit -> CvtM HsLit
cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim NoSourceText i }
cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim NoSourceText w }
cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim (cvtFractionalLit f) }
cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (cvtFractionalLit f) }
cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim (mkFractionalLit f) }
cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (mkFractionalLit f) }
cvtLit (CharL c) = do { force c; return $ HsChar NoSourceText c }
cvtLit (CharPrimL c) = do { force c; return $ HsCharPrim NoSourceText c }
cvtLit (StringL s) = do { let { s' = mkFastString s }
Expand Down Expand Up @@ -1428,9 +1428,6 @@ overloadedLit (IntegerL _) = True
overloadedLit (RationalL _) = True
overloadedLit _ = False

cvtFractionalLit :: Rational -> FractionalLit
cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = r }

-- Checks that are performed when converting unboxed sum expressions and
-- patterns alike.
unboxedSumChecks :: TH.SumAlt -> TH.SumArity -> CvtM ()
Expand Down
32 changes: 19 additions & 13 deletions compiler/hsSyn/HsLit.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -19,7 +19,8 @@ module HsLit where
#include "HsVersions.h"

import {-# SOURCE #-} HsExpr( HsExpr, pprExpr )
import BasicTypes ( FractionalLit(..),SourceText(..),pprWithSourceText )
import BasicTypes ( IntegralLit(..),FractionalLit(..),negateIntegralLit,
negateFractionalLit,SourceText(..),pprWithSourceText )
import Type ( Type )
import Outputable
import FastString
Expand Down Expand Up @@ -48,7 +49,7 @@ data HsLit
-- ^ String
| HsStringPrim SourceText ByteString
-- ^ Packed bytes
| HsInt SourceText Integer
| HsInt IntegralLit
-- ^ Genuinely an Int; arises from
-- @TcGenDeriv@, and from TRANSLATION
| HsIntPrim SourceText Integer
Expand Down Expand Up @@ -78,7 +79,7 @@ instance Eq HsLit where
(HsCharPrim _ x1) == (HsCharPrim _ x2) = x1==x2
(HsString _ x1) == (HsString _ x2) = x1==x2
(HsStringPrim _ x1) == (HsStringPrim _ x2) = x1==x2
(HsInt _ x1) == (HsInt _ x2) = x1==x2
(HsInt x1) == (HsInt x2) = x1==x2
(HsIntPrim _ x1) == (HsIntPrim _ x2) = x1==x2
(HsWordPrim _ x1) == (HsWordPrim _ x2) = x1==x2
(HsInt64Prim _ x1) == (HsInt64Prim _ x2) = x1==x2
Expand All @@ -102,11 +103,16 @@ deriving instance (DataId id) => Data (HsOverLit id)
-- the following
-- | Overloaded Literal Value
data OverLitVal
= HsIntegral !SourceText !Integer -- ^ Integer-looking literals;
= HsIntegral !IntegralLit -- ^ Integer-looking literals;
| HsFractional !FractionalLit -- ^ Frac-looking literals
| HsIsString !SourceText !FastString -- ^ String-looking literals
deriving Data

negateOverLitVal :: OverLitVal -> OverLitVal
negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i)
negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f)
negateOverLitVal _ = panic "negateOverLitVal: argument is not a number"

overLitType :: HsOverLit a -> PostTc a Type
overLitType = ol_type

Expand Down Expand Up @@ -146,7 +152,7 @@ instance Eq (HsOverLit id) where
(OverLit {ol_val = val1}) == (OverLit {ol_val=val2}) = val1 == val2

instance Eq OverLitVal where
(HsIntegral _ i1) == (HsIntegral _ i2) = i1 == i2
(HsIntegral i1) == (HsIntegral i2) = i1 == i2
(HsFractional f1) == (HsFractional f2) = f1 == f2
(HsIsString _ s1) == (HsIsString _ s2) = s1 == s2
_ == _ = False
Expand All @@ -155,22 +161,22 @@ instance Ord (HsOverLit id) where
compare (OverLit {ol_val=val1}) (OverLit {ol_val=val2}) = val1 `compare` val2

instance Ord OverLitVal where
compare (HsIntegral _ i1) (HsIntegral _ i2) = i1 `compare` i2
compare (HsIntegral _ _) (HsFractional _) = LT
compare (HsIntegral _ _) (HsIsString _ _) = LT
compare (HsIntegral i1) (HsIntegral i2) = i1 `compare` i2
compare (HsIntegral _) (HsFractional _) = LT
compare (HsIntegral _) (HsIsString _ _) = LT
compare (HsFractional f1) (HsFractional f2) = f1 `compare` f2
compare (HsFractional _) (HsIntegral _ _) = GT
compare (HsFractional _) (HsIntegral _) = GT
compare (HsFractional _) (HsIsString _ _) = LT
compare (HsIsString _ s1) (HsIsString _ s2) = s1 `compare` s2
compare (HsIsString _ _) (HsIntegral _ _) = GT
compare (HsIsString _ _) (HsIntegral _) = GT
compare (HsIsString _ _) (HsFractional _) = GT

instance Outputable HsLit where
ppr (HsChar st c) = pprWithSourceText st (pprHsChar c)
ppr (HsCharPrim st c) = pp_st_suffix st primCharSuffix (pprPrimChar c)
ppr (HsString st s) = pprWithSourceText st (pprHsString s)
ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s)
ppr (HsInt st i) = pprWithSourceText st (integer i)
ppr (HsInt i) = pprWithSourceText (il_text i) (integer (il_value i))
ppr (HsInteger st i _) = pprWithSourceText st (integer i)
ppr (HsRat f _) = ppr f
ppr (HsFloatPrim f) = ppr f <> primFloatSuffix
Expand All @@ -190,7 +196,7 @@ instance (OutputableBndrId id) => Outputable (HsOverLit id) where
= ppr val <+> (ifPprDebug (parens (pprExpr witness)))

instance Outputable OverLitVal where
ppr (HsIntegral st i) = pprWithSourceText st (integer i)
ppr (HsIntegral i) = pprWithSourceText (il_text i) (integer (il_value i))
ppr (HsFractional f) = ppr f
ppr (HsIsString st s) = pprWithSourceText st (pprHsString s)

Expand All @@ -205,7 +211,7 @@ pmPprHsLit (HsChar _ c) = pprHsChar c
pmPprHsLit (HsCharPrim _ c) = pprHsChar c
pmPprHsLit (HsString st s) = pprWithSourceText st (pprHsString s)
pmPprHsLit (HsStringPrim _ s) = pprHsBytes s
pmPprHsLit (HsInt _ i) = integer i
pmPprHsLit (HsInt i) = integer (il_value i)
pmPprHsLit (HsIntPrim _ i) = integer i
pmPprHsLit (HsWordPrim _ w) = integer w
pmPprHsLit (HsInt64Prim _ i) = integer i
Expand Down
Loading

0 comments on commit 0279b74

Please sign in to comment.