Fix exponential typechecking time for large rationals (#15646)
authorJulian Leviston <julian@leviston.net>
Sat, 2 Feb 2019 05:53:09 +0000 (16:53 +1100)
committerMatthew Pickering <matthewtpickering@gmail.com>
Sat, 23 Mar 2019 11:10:32 +0000 (11:10 +0000)
16 files changed:
compiler/basicTypes/BasicTypes.hs
compiler/basicTypes/Literal.hs
compiler/coreSyn/MkCore.hs
compiler/deSugar/Match.hs
compiler/deSugar/MatchLit.hs
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsLit.hs
compiler/parser/Lexer.x
compiler/prelude/PrelNames.hs
compiler/rename/RnPat.hs
compiler/typecheck/TcHsSyn.hs
compiler/utils/Util.hs
libraries/base/GHC/Real.hs
testsuite/tests/ghc-api/annotations-literals/literals.stdout
testsuite/tests/typecheck/should_compile/T15646.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/all.T

index ded9c0d..af33a44 100644 (file)
@@ -97,9 +97,9 @@ module BasicTypes(
 
         SuccessFlag(..), succeeded, failed, successIf,
 
-        IntegralLit(..), FractionalLit(..),
-        negateIntegralLit, negateFractionalLit,
-        mkIntegralLit, mkFractionalLit,
+        IntegralLit(..), FractionalLit(..), FractionalExponentBase(..),
+        negateIntegralLit, negateFractionalLit, fractionalLitNeg,
+        mkIntegralLit, mkFractionalLit, mkTHFractionalLit, rationalFromFractionalLit,
         integralFractionalLit,
 
         SourceText(..), pprWithSourceText,
@@ -116,6 +116,7 @@ import Outputable
 import SrcLoc ( Located,unLoc )
 import Data.Data hiding (Fixity, Prefix, Infix)
 import Data.Function (on)
+import GHC.Real (Ratio((:%)))
 
 {-
 ************************************************************************
@@ -1481,20 +1482,54 @@ negateIntegralLit (IL text neg value)
 
 -- | Fractional Literal
 --
--- Used (instead of Rational) to represent exactly the floating point literal that we
+-- Used (instead of Rational) to represent the exact 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 :: SourceText     -- How the value was written in the source
-       , fl_neg :: Bool            -- See Note [Negative zero]
-       , fl_value :: Rational      -- Numeric value of the literal
+  = FL { fl_text :: SourceText                 -- How the value was written in the source
+       , fl_neg :: Bool                        -- See Note [Negative zero]
+       , fl_signi :: Integer                   -- The significand component of the literal
+       , fl_exp :: Integer                     -- The exponent component of the literal
+       , fl_exp_base :: FractionalExponentBase -- See Note [Fractional exponent bases]
        }
+  -- | TemplateHaskell fractional lit: we lose information during conversion
+  -- from Haskell syntax to TH syntax (happens when desugaring quasiquotes, in
+  -- DsMeta) where we convert a `FL` to a `Rational` because that's what TH
+  -- syntax wants.
+  | THFL { thfl_text :: SourceText -- How the value was written in the source
+         , thfl_neg :: Bool        -- See Note [Negative zero]
+         , thfl_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))
+fractionalLitNeg :: FractionalLit -> Bool
+fractionalLitNeg fl =
+  case fl of
+    FL {} -> fl_neg fl
+    THFL {} -> thfl_neg fl
+  
+data FractionalExponentBase
+  = Base2
+  | Base10
+  deriving (Data, Show)
+
+mkRationalBase10 :: Integer -> Integer -> Rational
+mkRationalBase10 i e = mkRationalWithExponentBase i e Base10
+
+mkRationalWithExponentBase :: Integer -> Integer -> FractionalExponentBase -> Rational
+mkRationalWithExponentBase i e feb = (i :% 1) * (eb ^^ e)
+  where eb = case feb of Base2 -> 2 ; Base10 -> 10
+  
+rationalFromFractionalLit :: FractionalLit -> Rational
+rationalFromFractionalLit (FL _ _ i e expBase) =
+  mkRationalWithExponentBase i e expBase
+rationalFromFractionalLit (THFL _ _ r) = r
+
+
+mkFractionalLit :: Integer -> Integer -> FractionalLit
+mkFractionalLit i e = FL { fl_text = SourceText (show (realToFrac (mkRationalBase10 i e)::Double))
                            -- Converting to a Double here may technically lose
                            -- precision (see #15502). We could alternatively
                            -- convert to a Rational for the most accuracy, but
@@ -1502,20 +1537,45 @@ mkFractionalLit r = FL { fl_text = SourceText (show (realToFrac r::Double))
                            -- strangely, so we opt not to do this. (In contrast
                            -- to mkIntegralLit, where we always convert to an
                            -- Integer for the highest accuracy.)
-                       , fl_neg = r < 0
-                       , fl_value = toRational r }
+                         , fl_neg = i < 0
+                         , fl_signi = i
+                         , fl_exp = e
+                         , fl_exp_base = Base10 }
+
+mkTHFractionalLit :: Rational -> FractionalLit
+mkTHFractionalLit r = THFL { thfl_text = SourceText (show (realToFrac r::Double))
+                             -- Converting to a Double here may technically lose
+                             -- precision (see #15502). We could alternatively
+                             -- convert to a Rational for the most accuracy, but
+                             -- it would cause Floats and Doubles to be displayed
+                             -- strangely, so we opt not to do this. (In contrast
+                             -- to mkIntegralLit, where we always convert to an
+                             -- Integer for the highest accuracy.)
+                           , thfl_neg = r < 0
+                           , thfl_value = r }
 
 negateFractionalLit :: FractionalLit -> FractionalLit
-negateFractionalLit (FL text neg value)
+negateFractionalLit (FL text neg i e eb)
+  = case text of
+      SourceText ('-':src) -> FL (SourceText src)       False i e eb
+      SourceText      src  -> FL (SourceText ('-':src)) True  i e eb
+      NoSourceText         -> FL NoSourceText (not neg) (negate i) e eb
+negateFractionalLit (THFL text neg r)
   = case text of
-      SourceText ('-':src) -> FL (SourceText src)     False value
-      SourceText      src  -> FL (SourceText ('-':src)) True  value
-      NoSourceText         -> FL NoSourceText (not neg) (negate value)
+      SourceText ('-':src) -> THFL (SourceText src)       False r
+      SourceText      src  -> THFL (SourceText ('-':src)) True  r
+      NoSourceText         -> THFL NoSourceText (not neg) (negate r)
 
 integralFractionalLit :: Bool -> Integer -> FractionalLit
-integralFractionalLit neg i = FL { fl_text = SourceText (show i),
-                                   fl_neg = neg,
-                                   fl_value = fromInteger i }
+integralFractionalLit neg i = FL { fl_text = SourceText (show i)
+                                 , fl_neg = neg
+                                 , fl_signi = i
+                                 , fl_exp = 0
+                                 , fl_exp_base = Base10 }
+
+-- Note [fractional exponent bases] For hexadecimal rationals of
+-- the form 0x0.3p10 the exponent is given on base 2 rather than
+-- base 10. These are the only options, hence the sum type. See also #15646.
 
 -- Comparison operations are needed when grouping literals
 -- for compiling pattern-matching (module MatchLit)
@@ -1531,13 +1591,14 @@ instance Outputable IntegralLit where
   ppr (IL NoSourceText _ value) = text (show value)
 
 instance Eq FractionalLit where
-  (==) = (==) `on` fl_value
+  (==) = (==) `on` (\x -> mkRationalWithExponentBase (fl_signi x) (fl_exp x) (fl_exp_base x))
 
 instance Ord FractionalLit where
-  compare = compare `on` fl_value
+  compare = compare `on` (\x -> mkRationalWithExponentBase (fl_signi x) (fl_exp x) (fl_exp_base x))
 
 instance Outputable FractionalLit where
-  ppr f = pprWithSourceText (fl_text f) (rational (fl_value f))
+  ppr (fl@(FL {})) = pprWithSourceText (fl_text fl) (rational $ mkRationalWithExponentBase (fl_signi fl) (fl_exp fl) (fl_exp_base fl))
+  ppr (fl@(THFL {})) = pprWithSourceText (thfl_text fl) (rational $ thfl_value fl)
 
 {-
 ************************************************************************
index 8dd6708..b258d5a 100644 (file)
@@ -20,7 +20,7 @@ module Literal
         , mkLitWord64, mkLitWord64Wrap
         , mkLitFloat, mkLitDouble
         , mkLitChar, mkLitString
-        , mkLitInteger, mkLitNatural
+        , mkLitInteger, mkLitNatural, mkLitRational
         , mkLitNumber, mkLitNumberWrap
 
         -- ** Operations on Literals
@@ -111,6 +111,8 @@ data Literal
   | LitNumber !LitNumType !Integer Type
                                 -- ^ Any numeric literal that can be
                                 -- internally represented with an Integer
+  | LitRational !Integer !Integer Type
+                                --  ^ Rationals expressed as significand and exponent
 
   | LitString  ByteString       -- ^ A string-literal: stored and emitted
                                 -- UTF-8 encoded, we'll arrange to decode it
@@ -225,7 +227,11 @@ instance Binary Literal where
         = do putByte bh 6
              put_ bh nt
              put_ bh i
-    put_ bh (LitRubbish)     = do putByte bh 7
+    put_ bh (LitRational i e _)
+        = do putByte bh 7
+             put_ bh i
+             put_ bh e
+    put_ bh (LitRubbish)      = do putByte bh 8
     get bh = do
             h <- getByte bh
             case h of
@@ -263,6 +269,11 @@ instance Binary Literal where
                             LitNumNatural ->
                               panic "Evaluated the place holder for mkNatural"
                     return (LitNumber nt i t)
+              7 -> do
+                    i <- get bh
+                    e <- get bh
+                    let t = panic "Evaluated the place holder for mkRational"
+                    return (LitRational i e t)
               _ -> do
                     return (LitRubbish)
 
@@ -437,6 +448,9 @@ mkLitString s = LitString (bytesFS $ mkFastString s)
 mkLitInteger :: Integer -> Type -> Literal
 mkLitInteger x ty = LitNumber LitNumInteger x ty
 
+mkLitRational :: Integer -> Integer -> Type -> Literal
+mkLitRational i e ty = LitRational i e ty
+
 mkLitNatural :: Integer -> Type -> Literal
 mkLitNatural x ty = ASSERT2( inNaturalRange x,  integer x )
                     (LitNumber LitNumNatural x ty)
@@ -616,15 +630,16 @@ litIsTrivial _                  = True
 -- | True if code space does not go bad if we duplicate this literal
 litIsDupable :: DynFlags -> Literal -> Bool
 --      c.f. CoreUtils.exprIsDupable
-litIsDupable _      (LitString _)      = False
-litIsDupable dflags (LitNumber nt i _) = case nt of
+litIsDupable _      (LitString _)       = False
+litIsDupable dflags (LitNumber nt i _)  = case nt of
   LitNumInteger -> inIntRange dflags i
   LitNumNatural -> inIntRange dflags i
   LitNumInt     -> True
   LitNumInt64   -> True
   LitNumWord    -> True
   LitNumWord64  -> True
-litIsDupable _      _                  = True
+litIsDupable _ (LitRational _ _ _)      = True
+litIsDupable _      _                   = True
 
 litFitsInChar :: Literal -> Bool
 litFitsInChar (LitNumber _ i _) = i >= toInteger (ord minBound)
@@ -648,14 +663,15 @@ litIsLifted _                  = False
 
 -- | Find the Haskell 'Type' the literal occupies
 literalType :: Literal -> Type
-literalType LitNullAddr       = addrPrimTy
-literalType (LitChar _)       = charPrimTy
-literalType (LitString  _)    = addrPrimTy
-literalType (LitFloat _)      = floatPrimTy
-literalType (LitDouble _)     = doublePrimTy
-literalType (LitLabel _ _ _)  = addrPrimTy
-literalType (LitNumber _ _ t) = t
-literalType (LitRubbish)      = mkForAllTy a Inferred (mkTyVarTy a)
+literalType LitNullAddr         = addrPrimTy
+literalType (LitChar _)         = charPrimTy
+literalType (LitString  _)      = addrPrimTy
+literalType (LitFloat _)        = floatPrimTy
+literalType (LitDouble _)       = doublePrimTy
+literalType (LitLabel _ _ _)    = addrPrimTy
+literalType (LitNumber _ _ t)   = t
+literalType (LitRational _ _ t) = t
+literalType (LitRubbish)        = mkForAllTy a Inferred (mkTyVarTy a)
   where
     a = alphaTyVarUnliftedRep
 
@@ -693,20 +709,24 @@ cmpLit (LitLabel     a _ _) (LitLabel      b _ _) = a `compare` b
 cmpLit (LitNumber nt1 a _)  (LitNumber nt2  b _)
   | nt1 == nt2 = a   `compare` b
   | otherwise  = nt1 `compare` nt2
+cmpLit (LitRational i1 e1 _) (LitRational i2 e2 _)
+  | e1 == e2 = i1 `compare` i2
+  | otherwise = e1 `compare` e2
 cmpLit (LitRubbish)         (LitRubbish)          = EQ
 cmpLit lit1 lit2
   | litTag lit1 < litTag lit2 = LT
   | otherwise                 = GT
 
 litTag :: Literal -> Int
-litTag (LitChar      _)   = 1
-litTag (LitString    _)   = 2
-litTag (LitNullAddr)      = 3
-litTag (LitFloat     _)   = 4
-litTag (LitDouble    _)   = 5
-litTag (LitLabel _ _ _)   = 6
-litTag (LitNumber  {})    = 7
-litTag (LitRubbish)       = 8
+litTag (LitChar      _)    = 1
+litTag (LitString    _)    = 2
+litTag (LitNullAddr)       = 3
+litTag (LitFloat     _)    = 4
+litTag (LitDouble    _)    = 5
+litTag (LitLabel _ _ _)    = 6
+litTag (LitNumber  {})     = 7
+litTag (LitRational _ _ _) = 8
+litTag (LitRubbish)        = 9
 
 {-
         Printing
@@ -728,6 +748,8 @@ pprLiteral add_par (LitNumber nt i _)
        LitNumInt64   -> pprPrimInt64 i
        LitNumWord    -> pprPrimWord i
        LitNumWord64  -> pprPrimWord64 i
+pprLiteral add_par (LitRational i e _) =
+    (pprIntegerVal add_par i) <> (text "e") <> (pprIntegerVal add_par e)
 pprLiteral add_par (LitLabel l mb fod) =
     add_par (text "__label" <+> b <+> ppr fod)
     where b = case mb of
index f9609f8..484c3b0 100644 (file)
@@ -12,7 +12,7 @@ module MkCore (
         -- * Constructing boxed literals
         mkWordExpr, mkWordExprWord,
         mkIntExpr, mkIntExprInt,
-        mkIntegerExpr, mkNaturalExpr,
+        mkIntegerExpr, mkNaturalExpr, mkRationalExpr,
         mkFloatExpr, mkDoubleExpr,
         mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith,
 
@@ -258,6 +258,11 @@ mkIntegerExpr  :: MonadThings m => Integer -> m CoreExpr  -- Result :: Integer
 mkIntegerExpr i = do t <- lookupTyCon integerTyConName
                      return (Lit (mkLitInteger i (mkTyConTy t)))
 
+-- | Create a 'CoreExpr' which will evaluate to a @Rational@ with given significand and exponent
+mkRationalExpr  :: MonadThings m => Integer -> Integer -> m CoreExpr  -- Result :: Rational
+mkRationalExpr i e = do t <- lookupTyCon rationalTyConName
+                        return (Lit (mkLitRational i e (mkTyConTy t)))
+
 -- | Create a 'CoreExpr' which will evaluate to the given @Natural@
 mkNaturalExpr  :: MonadThings m => Integer -> m CoreExpr
 mkNaturalExpr i = do t <- lookupTyCon naturalTyConName
index c057298..a130975 100644 (file)
@@ -49,7 +49,7 @@ import Maybes
 import Util
 import Name
 import Outputable
-import BasicTypes ( isGenerated, il_value, fl_value )
+import BasicTypes ( isGenerated, il_value, fl_signi, fl_exp )
 import FastString
 import Unique
 import UniqDFM
@@ -842,21 +842,21 @@ matchSinglePatVar var ctx pat ty match_result
 -}
 
 data PatGroup
-  = PgAny               -- Immediate match: variables, wildcards,
-                        --                  lazy patterns
-  | PgCon DataCon       -- Constructor patterns (incl list, tuple)
-  | PgSyn PatSyn [Type] -- See Note [Pattern synonym groups]
-  | PgLit Literal       -- Literal patterns
-  | PgN   Rational      -- Overloaded numeric literals;
-                        -- see Note [Don't use Literal for PgN]
-  | PgOverS FastString  -- Overloaded string literals
-  | PgNpK Integer       -- n+k patterns
-  | PgBang              -- Bang patterns
-  | PgCo Type           -- Coercion patterns; the type is the type
-                        --      of the pattern *inside*
+  = PgAny                  -- Immediate match: variables, wildcards,
+                           --                  lazy patterns
+  | PgCon DataCon          -- Constructor patterns (incl list, tuple)
+  | PgSyn PatSyn [Type]    -- See Note [Pattern synonym groups]
+  | PgLit Literal          -- Literal patterns
+  | PgN   Integer Integer  -- Overloaded numeric literals;
+                           -- see Note [Don't use Literal for PgN]
+  | PgOverS FastString     -- Overloaded string literals
+  | PgNpK Integer          -- n+k patterns
+  | PgBang                 -- Bang patterns
+  | PgCo Type              -- Coercion patterns; the type is the type
+                           --      of the pattern *inside*
   | PgView (LHsExpr GhcTc) -- view pattern (e -> p):
-                        -- the LHsExpr is the expression e
-           Type         -- the Type is the type of p (equivalently, the result type of e)
+                           -- the LHsExpr is the expression e
+           Type            -- the Type is the type of p (equivalently, the result type of e)
   | PgOverloadedList
 
 {- Note [Don't use Literal for PgN]
@@ -875,8 +875,8 @@ the invariant that value in a LitInt must be in the range of the target
 machine's Int# type, and an overloaded literal could meaningfully be larger.
 
 Solution: For pattern grouping purposes, just store the literal directly in
-the PgN constructor as a Rational if numeric, and add a PgOverStr constructor
-for overloaded strings.
+the PgN constructor if numeric, and add a PgOverStr constructor for overloaded
+strings.
 -}
 
 groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]]
@@ -958,7 +958,8 @@ sameGroup (PgCon _)     (PgCon _)     = True    -- One case expression
 sameGroup (PgSyn p1 t1) (PgSyn p2 t2) = p1==p2 && eqTypes t1 t2
                                                 -- eqTypes: See Note [Pattern synonym groups]
 sameGroup (PgLit _)     (PgLit _)     = True    -- One case expression
-sameGroup (PgN l1)      (PgN l2)      = l1==l2  -- Order is significant
+sameGroup (PgN i1 e1)   (PgN i2 e2)   = i1==i2 && e1==e2
+                                                -- Order is significant
 sameGroup (PgOverS s1)  (PgOverS s2)  = s1==s2
 sameGroup (PgNpK l1)    (PgNpK l2)    = l1==l2  -- See Note [Grouping overloaded literal patterns]
 sameGroup (PgCo t1)     (PgCo t2)     = t1 `eqType` t2
@@ -1091,10 +1092,10 @@ patGroup _ (WildPat {})                 = PgAny
 patGroup _ (BangPat {})                 = PgBang
 patGroup _ (NPat _ (dL->L _ (OverLit {ol_val=oval})) mb_neg _) =
   case (oval, isJust mb_neg) of
-   (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)
+   (HsIntegral   i, False) -> PgN (il_value i) 0
+   (HsIntegral   i, True ) -> PgN (-il_value i) 0
+   (HsFractional r, False) -> PgN (fl_signi r) (fl_exp r)
+   (HsFractional r, True ) -> PgN (-fl_signi r) (fl_exp r)
    (HsIsString _ s, _) -> ASSERT(isNothing mb_neg)
                           PgOverS s
 patGroup _ (NPlusKPat _ _ (dL->L _ (OverLit {ol_val=oval})) _ _ _) =
index d99ae7e..9127a35 100644 (file)
@@ -83,20 +83,33 @@ dsLit :: HsLit GhcRn -> DsM CoreExpr
 dsLit l = do
   dflags <- getDynFlags
   case l of
-    HsStringPrim _ s -> return (Lit (LitString s))
-    HsCharPrim   _ c -> return (Lit (LitChar c))
-    HsIntPrim    _ i -> return (Lit (mkLitIntWrap dflags i))
-    HsWordPrim   _ w -> return (Lit (mkLitWordWrap dflags w))
-    HsInt64Prim  _ i -> return (Lit (mkLitInt64Wrap dflags i))
-    HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap dflags w))
-    HsFloatPrim  _ f -> return (Lit (LitFloat (fl_value f)))
-    HsDoublePrim _ d -> return (Lit (LitDouble (fl_value d)))
-    HsChar _ c       -> return (mkCharExpr c)
-    HsString _ str   -> mkStringExprFS str
-    HsInteger _ i _  -> mkIntegerExpr i
-    HsInt _ i        -> return (mkIntExpr dflags (il_value i))
-    XLit x           -> pprPanic "dsLit" (ppr x)
-    HsRat _ (FL _ _ val) ty -> do
+    HsStringPrim _ s  -> return (Lit (LitString s))
+    HsCharPrim   _ c  -> return (Lit (LitChar c))
+    HsIntPrim    _ i  -> return (Lit (mkLitIntWrap dflags i))
+    HsWordPrim   _ w  -> return (Lit (mkLitWordWrap dflags w))
+    HsInt64Prim  _ i  -> return (Lit (mkLitInt64Wrap dflags i))
+    HsWord64Prim _ w  -> return (Lit (mkLitWord64Wrap dflags w))
+    HsFloatPrim  _ fl -> return (Lit (LitFloat (rationalFromFractionalLit fl)))
+    HsDoublePrim _ fl -> return (Lit (LitDouble (rationalFromFractionalLit fl)))
+    HsChar _ c        -> return (mkCharExpr c)
+    HsString _ str    -> mkStringExprFS str
+    HsInteger _ i _   -> mkIntegerExpr i
+    HsInt _ i         -> return (mkIntExpr dflags (il_value i))
+    HsRat _ fl ty     -> dsFractionalLitToRational fl ty
+    XLit x            -> pprPanic "dsLit" (ppr x)
+
+dsFractionalLitToRational :: FractionalLit -> Type -> DsM CoreExpr
+dsFractionalLitToRational fl ty =
+  case fl of
+    FL { fl_signi = fl_signi, fl_exp = fl_exp, fl_exp_base = feb } -> do
+      let mkRationalName = case feb of 
+                             Base2 -> mkRationalBase2Name
+                             Base10 -> mkRationalBase10Name
+      mkRational <- dsLookupGlobalId mkRationalName
+      litI <- mkIntegerExpr fl_signi
+      litE <- mkIntegerExpr fl_exp
+      return ((Var mkRational) `App` litI `App` litE)
+    THFL { thfl_value = val } -> do
       num   <- mkIntegerExpr (numerator val)
       denom <- mkIntegerExpr (denominator val)
       return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
@@ -107,6 +120,7 @@ dsLit l = do
                                        (head (tyConDataCons tycon), i_ty)
                     x -> pprPanic "dsLit" (ppr x)
 
+
 dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr
 -- ^ Post-typechecker, the 'HsExpr' field of an 'OverLit' contains
 -- (an expression for) the literal value itself.
@@ -449,15 +463,15 @@ hsLitKey :: DynFlags -> HsLit GhcTc -> Literal
 -- In the case of the fixed-width numeric types, we need to wrap here
 -- because Literal has an invariant that the literal is in range, while
 -- HsLit does not.
-hsLitKey dflags (HsIntPrim    _ i) = mkLitIntWrap  dflags i
-hsLitKey dflags (HsWordPrim   _ w) = mkLitWordWrap dflags w
-hsLitKey dflags (HsInt64Prim  _ i) = mkLitInt64Wrap  dflags i
-hsLitKey dflags (HsWord64Prim _ w) = mkLitWord64Wrap dflags w
-hsLitKey _      (HsCharPrim   _ c) = mkLitChar            c
-hsLitKey _      (HsFloatPrim  _ f) = mkLitFloat           (fl_value f)
-hsLitKey _      (HsDoublePrim _ d) = mkLitDouble          (fl_value d)
-hsLitKey _      (HsString _ s)     = LitString (bytesFS s)
-hsLitKey _      l                  = pprPanic "hsLitKey" (ppr l)
+hsLitKey dflags (HsIntPrim    _ i)  = mkLitIntWrap  dflags i
+hsLitKey dflags (HsWordPrim   _ w)  = mkLitWordWrap dflags w
+hsLitKey dflags (HsInt64Prim  _ i)  = mkLitInt64Wrap  dflags i
+hsLitKey dflags (HsWord64Prim _ w)  = mkLitWord64Wrap dflags w
+hsLitKey _      (HsCharPrim   _ c)  = mkLitChar            c
+hsLitKey _      (HsFloatPrim  _ fl) = mkLitFloat (rationalFromFractionalLit fl)
+hsLitKey _      (HsDoublePrim _ fl) = mkLitDouble (rationalFromFractionalLit fl)
+hsLitKey _      (HsString _ s)      = LitString (bytesFS s)
+hsLitKey _      l                   = pprPanic "hsLitKey" (ppr l)
 
 {-
 ************************************************************************
index 77ffebe..6ad68be 100644 (file)
@@ -1146,7 +1146,7 @@ cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs)
 cvtOverLit (IntegerL i)
   = do { force i; return $ mkHsIntegral   (mkIntegralLit i) }
 cvtOverLit (RationalL r)
-  = do { force r; return $ mkHsFractional (mkFractionalLit r) }
+  = do { force r; return $ mkHsFractional (mkTHFractionalLit r) }
 cvtOverLit (StringL s)
   = do { let { s' = mkFastString s }
        ; force s'
@@ -1181,9 +1181,9 @@ cvtLit :: Lit -> CvtM (HsLit GhcPs)
 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 noExt (mkFractionalLit f) }
+  = do { force f; return $ HsFloatPrim noExt (mkTHFractionalLit f) }
 cvtLit (DoublePrimL f)
-  = do { force f; return $ HsDoublePrim noExt (mkFractionalLit f) }
+  = do { force f; return $ HsDoublePrim noExt (mkTHFractionalLit 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 }
index d1411bd..f044a89 100644 (file)
@@ -22,7 +22,8 @@ import GhcPrelude
 
 import {-# SOURCE #-} HsExpr( HsExpr, pprExpr )
 import BasicTypes ( IntegralLit(..),FractionalLit(..),negateIntegralLit,
-                    negateFractionalLit,SourceText(..),pprWithSourceText )
+                    negateFractionalLit,SourceText(..),pprWithSourceText,
+                    fractionalLitNeg )
 import Type
 import Outputable
 import FastString
@@ -297,9 +298,9 @@ hsLitNeedsParens p = go
     go (HsInt64Prim _ x)  = p > topPrec && x < 0
     go (HsWord64Prim {})  = False
     go (HsInteger _ x _)  = p > topPrec && x < 0
-    go (HsRat _ x _)      = p > topPrec && fl_neg x
-    go (HsFloatPrim _ x)  = p > topPrec && fl_neg x
-    go (HsDoublePrim _ x) = p > topPrec && fl_neg x
+    go (HsRat _ x _)      = p > topPrec && fractionalLitNeg x
+    go (HsFloatPrim _ x)  = p > topPrec && fractionalLitNeg x
+    go (HsDoublePrim _ x) = p > topPrec && fractionalLitNeg x
     go (XLit _)           = False
 
 -- | @'hsOverLitNeedsParens' p ol@ returns 'True' if an overloaded literal
@@ -309,6 +310,6 @@ hsOverLitNeedsParens p (OverLit { ol_val = olv }) = go olv
   where
     go :: OverLitVal -> Bool
     go (HsIntegral x)   = p > topPrec && il_neg x
-    go (HsFractional x) = p > topPrec && fl_neg x
+    go (HsFractional x) = p > topPrec && fractionalLitNeg x
     go (HsIsString {})  = False
 hsOverLitNeedsParens _ (XOverLit { }) = False
index 7c08cea..167aab0 100644 (file)
@@ -93,7 +93,7 @@ import Outputable
 import StringBuffer
 import FastString
 import UniqFM
-import Util             ( readRational, readHexRational )
+import Util             ( readSignificandExponentPair, readHexSignificandExponentPair )
 
 -- compiler/main
 import ErrUtils
@@ -104,7 +104,7 @@ import SrcLoc
 import Module
 import BasicTypes     ( InlineSpec(..), RuleMatchInfo(..),
                         IntegralLit(..), FractionalLit(..),
-                        SourceText(..) )
+                        FractionalExponentBase(..), SourceText(..) )
 
 -- compiler/parser
 import Ctype
@@ -1418,7 +1418,7 @@ binary = (2,octDecDigit)
 octal = (8,octDecDigit)
 hexadecimal = (16,hexDigit)
 
--- readRational can understand negative rationals, exponents, everything.
+-- readSignificandExponentPair can understand negative rationals, exponents, everything.
 tok_frac :: Int -> (String -> Token) -> Action
 tok_frac drop f span buf len = do
   numericUnderscores <- getBit NumericUnderscoresBit  -- #14473
@@ -1436,17 +1436,23 @@ tok_primfloat    str = ITprimfloat  $! readFractionalLit str
 tok_primdouble   str = ITprimdouble $! readFractionalLit str
 
 readFractionalLit :: String -> FractionalLit
-readFractionalLit str = ((FL $! (SourceText str)) $! is_neg) $! readRational str
+readFractionalLit str = ((((FL $! (SourceText str)) $! is_neg) $! i) $! e) $! eb
                         where is_neg = case str of ('-':_) -> True
                                                    _       -> False
+                              (i, e) = readSignificandExponentPair str
+                              eb     = Base10
+
 readHexFractionalLit :: String -> FractionalLit
 readHexFractionalLit str =
   FL { fl_text  = SourceText str
      , fl_neg   = case str of
                     '-' : _ -> True
                     _       -> False
-     , fl_value = readHexRational str
+     , fl_signi = i
+     , fl_exp = e
+     , fl_exp_base = Base2
      }
+  where (i, e) = readHexSignificandExponentPair str
 
 -- -----------------------------------------------------------------------------
 -- Layout processing
index 4a104c6..a892bfb 100644 (file)
@@ -285,6 +285,7 @@ basicKnownKeyNames
 
         -- Numeric stuff
         negateName, minusName, geName, eqName,
+        mkRationalBase2Name, mkRationalBase10Name,
 
         -- Conversion functions
         rationalTyConName,
@@ -1182,22 +1183,24 @@ mkNaturalName         = varQual gHC_NATURAL (fsLit "mkNatural")         mkNatura
 wordToNaturalName     = varQual gHC_NATURAL (fsLit "wordToNatural#")    wordToNaturalIdKey
 
 -- GHC.Real types and classes
-rationalTyConName, ratioTyConName, ratioDataConName, realClassName,
-    integralClassName, realFracClassName, fractionalClassName,
-    fromRationalName, toIntegerName, toRationalName, fromIntegralName,
-    realToFracName :: Name
-rationalTyConName   = tcQual  gHC_REAL (fsLit "Rational")     rationalTyConKey
-ratioTyConName      = tcQual  gHC_REAL (fsLit "Ratio")        ratioTyConKey
-ratioDataConName    = dcQual  gHC_REAL (fsLit ":%")           ratioDataConKey
-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    = varQual gHC_REAL (fsLit "fromRational") fromRationalClassOpKey
-toIntegerName       = varQual gHC_REAL (fsLit "toInteger")    toIntegerClassOpKey
-toRationalName      = varQual gHC_REAL (fsLit "toRational")   toRationalClassOpKey
-fromIntegralName    = varQual  gHC_REAL (fsLit "fromIntegral")fromIntegralIdKey
-realToFracName      = varQual  gHC_REAL (fsLit "realToFrac")  realToFracIdKey
+rationalTyConName, mkRationalBase2Name, mkRationalBase10Name, ratioTyConName,
+    ratioDataConName, realClassName, integralClassName, realFracClassName,
+    fractionalClassName, fromRationalName, toIntegerName, toRationalName,
+    fromIntegralName, realToFracName :: Name
+rationalTyConName    = tcQual   gHC_REAL  (fsLit "Rational")         rationalTyConKey
+ratioTyConName       = tcQual   gHC_REAL  (fsLit "Ratio")            ratioTyConKey
+ratioDataConName     = dcQual   gHC_REAL  (fsLit ":%")               ratioDataConKey
+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
+mkRationalBase2Name  = varQual  gHC_REAL  (fsLit "mkRationalBase2")  mkRationalBase2IdKey
+mkRationalBase10Name = varQual  gHC_REAL  (fsLit "mkRationalBase10") mkRationalBase10IdKey
+fromRationalName     = varQual  gHC_REAL  (fsLit "fromRational")     fromRationalClassOpKey
+toIntegerName        = varQual  gHC_REAL  (fsLit "toInteger")        toIntegerClassOpKey
+toRationalName       = varQual  gHC_REAL  (fsLit "toRational")       toRationalClassOpKey
+fromIntegralName     = varQual  gHC_REAL  (fsLit "fromIntegral")     fromIntegralIdKey
+realToFracName       = varQual  gHC_REAL  (fsLit "realToFrac")       realToFracIdKey
 
 -- PrelFloat classes
 floatingClassName, realFloatClassName :: Name
@@ -2394,7 +2397,8 @@ makeStaticKey = mkPreludeMiscIdUnique 561
 -- Natural
 naturalFromIntegerIdKey, naturalToIntegerIdKey, plusNaturalIdKey,
    minusNaturalIdKey, timesNaturalIdKey, mkNaturalIdKey,
-   naturalSDataConKey, wordToNaturalIdKey :: Unique
+   naturalSDataConKey, wordToNaturalIdKey, mkRationalBase2IdKey,
+   mkRationalBase10IdKey :: Unique
 naturalFromIntegerIdKey = mkPreludeMiscIdUnique 562
 naturalToIntegerIdKey   = mkPreludeMiscIdUnique 563
 plusNaturalIdKey        = mkPreludeMiscIdUnique 564
@@ -2403,6 +2407,8 @@ timesNaturalIdKey       = mkPreludeMiscIdUnique 566
 mkNaturalIdKey          = mkPreludeMiscIdUnique 567
 naturalSDataConKey      = mkPreludeMiscIdUnique 568
 wordToNaturalIdKey      = mkPreludeMiscIdUnique 569
+mkRationalBase2IdKey    = mkPreludeMiscIdUnique 570
+mkRationalBase10IdKey   = mkPreludeMiscIdUnique 571
 
 {-
 ************************************************************************
index ca8c665..f0010e4 100644 (file)
@@ -831,18 +831,21 @@ rnLit _ = return ()
 -- Turn a Fractional-looking literal which happens to be an integer into an
 -- Integer-looking literal.
 generalizeOverLitVal :: OverLitVal -> OverLitVal
-generalizeOverLitVal (HsFractional (FL {fl_text=src,fl_neg=neg,fl_value=val}))
-    | denominator val == 1 = HsIntegral (IL { il_text=src
-                                            , il_neg=neg
-                                            , il_value=numerator val})
+generalizeOverLitVal (HsFractional fl@(FL {fl_text=src,fl_neg=neg,fl_exp=e}))
+    | e >= 0 && e <= 100 = HsIntegral (IL {il_text=src,il_neg=neg,il_value=numerator val})
+  where val = rationalFromFractionalLit fl
 generalizeOverLitVal lit = lit
 
 isNegativeZeroOverLit :: HsOverLit t -> Bool
 isNegativeZeroOverLit lit
  = case ol_val lit of
-        HsIntegral i   -> 0 == il_value i && il_neg i
-        HsFractional f -> 0 == fl_value f && fl_neg f
-        _              -> False
+        HsIntegral i    -> 0 == il_value i && il_neg i
+        -- For HsFractional, the value of fl is n * (b ^^ e) so it is sufficient
+        -- to check if n = 0. b is equal to either 2 or 10. We don't call
+        -- rationalFromFractionalLit here as it is expensive when e is big.
+        HsFractional (fl@(FL {})) -> 0 == fl_signi fl && fl_neg fl
+        HsFractional (fl@(THFL {})) -> 0 == thfl_value fl && thfl_neg fl
+        _               -> False
 
 {-
 Note [Negative zero]
index 52783e7..67826d2 100644 (file)
@@ -152,9 +152,16 @@ shortCutLit dflags (HsIntegral int@(IL src neg i)) ty
         -- literals, compiled without -O
 
 shortCutLit _ (HsFractional f) ty
-  | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim noExt f))
-  | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim noExt f))
+  | isFloatTy ty && valueInRange  = Just (mkLit floatDataCon  (HsFloatPrim noExt f))
+  | isDoubleTy ty && valueInRange = Just (mkLit doubleDataCon (HsDoublePrim noExt f))
   | otherwise     = Nothing
+  where
+    valueInRange = 
+      case f of 
+        FL { fl_exp = e } -> (-100) <= e && e <= 100
+        THFL { thfl_value = val } -> val >= 0 && val <= 10 ^ (100 :: Int)
+        -- We limit short-cutting Fractional Literals to when their power of 10
+        -- is less than 100, which ensures desugaring isn't slow.
 
 shortCutLit _ (HsIsString src s) ty
   | isStringTy ty = Just (HsLit noExt (HsString src s))
index 9e67a43..1d657d3 100644 (file)
@@ -90,7 +90,10 @@ module Util (
 
         -- * Floating point
         readRational,
+        readSignificandExponentPair,
         readHexRational,
+        readHexSignificandExponentPair,
+
 
         -- * read helpers
         maybeRead, maybeReadFuzzy,
@@ -1157,9 +1160,28 @@ exactLog2 x
 
 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
 readRational__ r = do
+      ((i, e), t) <- readSignificandExponentPair__ r
+      return ((i%1)*10^^e, t)
+
+readRational :: String -> Rational -- NB: *does* handle a leading "-"
+readRational top_s
+  = case top_s of
+      '-' : xs -> - (read_me xs)
+      xs       -> read_me xs
+  where
+    read_me s
+      = case (do { (x,"") <- readRational__ s ; return x }) of
+          [x] -> x
+          []  -> error ("readRational: no parse:"        ++ top_s)
+          _   -> error ("readRational: ambiguous parse:" ++ top_s)
+
+
+readSignificandExponentPair__ :: ReadS (Integer, Integer) -- NB: doesn't handle leading "-"
+readSignificandExponentPair__ r = do
      (n,d,s) <- readFix r
      (k,t)   <- readExp s
-     return ((n%1)*10^^(k-d), t)
+     let pair = (n, toInteger (k - d))
+     return (pair, t)
  where
      readFix r = do
         (ds,s)  <- lexDecDigits r
@@ -1193,17 +1215,17 @@ readRational__ r = do
                | p x       =  let (ys,zs) = span' p xs' in (x:ys,zs)
                | otherwise =  ([],xs)
 
-readRational :: String -> Rational -- NB: *does* handle a leading "-"
-readRational top_s
+readSignificandExponentPair :: String -> (Integer, Integer) -- NB: *does* handle a leading "-"
+readSignificandExponentPair top_s
   = case top_s of
-      '-' : xs -> - (read_me xs)
+      '-' : xs -> let (i, e) = read_me xs in (-i, e)
       xs       -> read_me xs
   where
     read_me s
-      = case (do { (x,"") <- readRational__ s ; return x }) of
+      = case (do { (x,"") <- readSignificandExponentPair__ s ; return x }) of
           [x] -> x
-          []  -> error ("readRational: no parse:"        ++ top_s)
-          _   -> error ("readRational: ambiguous parse:" ++ top_s)
+          []  -> error ("readSignificandExponentPair: no parse:"        ++ top_s)
+          _   -> error ("readSignificandExponentPair: ambiguous parse:" ++ top_s)
 
 
 readHexRational :: String -> Rational
@@ -1262,6 +1284,60 @@ readHexRational__ ('0' : x : rest)
 readHexRational__ _ = Nothing
 
 
+readHexSignificandExponentPair :: String -> (Integer, Integer)
+readHexSignificandExponentPair str =
+  case str of
+    '-' : xs -> let (i, e) = readMe xs in (-i, e)
+    xs       -> readMe xs
+  where
+  readMe as =
+    case readHexSignificandExponentPair__ as of
+      Just n -> n
+      _      -> error ("readHexSignificandExponentPair: no parse:" ++ str)
+
+
+readHexSignificandExponentPair__ :: String -> Maybe (Integer, Integer)
+readHexSignificandExponentPair__ ('0' : x : rest)
+  | x == 'X' || x == 'x' =
+  do let (front,rest2) = span' isHexDigit rest
+     guard (not (null front))
+     let frontNum = steps 16 0 front
+     case rest2 of
+       '.' : rest3 ->
+          do let (back,rest4) = span' isHexDigit rest3
+             guard (not (null back))
+             let backNum = steps 16 frontNum back
+                 exp1    = -4 * length back
+             case rest4 of
+               p : ps | isExp p -> fmap (mk backNum . (+ exp1)) (getExp ps)
+               _ -> return (mk backNum exp1)
+       p : ps | isExp p -> fmap (mk frontNum) (getExp ps)
+       _ -> Nothing
+
+  where
+  isExp p = p == 'p' || p == 'P'
+
+  getExp ('+' : ds) = dec ds
+  getExp ('-' : ds) = fmap negate (dec ds)
+  getExp ds         = dec ds
+
+  mk :: Integer -> Int -> (Integer, Integer)
+  mk n e = (n, fromIntegral e)
+
+  dec cs = case span' isDigit cs of
+             (ds,"") | not (null ds) -> Just (steps 10 0 ds)
+             _ -> Nothing
+
+  steps base n ds = foldl' (step base) n ds
+  step  base n d  = base * n + fromIntegral (digitToInt d)
+
+  span' _ xs@[]         =  (xs, xs)
+  span' p xs@(x:xs')
+            | x == '_'  = span' p xs'   -- skip "_"  (#14473)
+            | p x       =  let (ys,zs) = span' p xs' in (x:ys,zs)
+            | otherwise =  ([],xs)
+
+readHexSignificandExponentPair__ _ = Nothing
 
 
 -----------------------------------------------------------------------------
index 8a47720..b366c31 100644 (file)
@@ -792,3 +792,24 @@ integralEnumFromTo n m = map fromInteger [toInteger n .. toInteger m]
 integralEnumFromThenTo :: Integral a => a -> a -> a -> [a]
 integralEnumFromThenTo n1 n2 m
   = map fromInteger [toInteger n1, toInteger n2 .. toInteger m]
+
+-- mkRational related code
+
+data FractionalExponentBase
+  = Base2
+  | Base10
+  deriving (Show)
+
+mkRationalBase2 :: Integer -> Integer -> Rational
+mkRationalBase2 i e = mkRationalWithExponentBase i e Base2
+
+mkRationalBase10 :: Integer -> Integer -> Rational
+mkRationalBase10 i e = mkRationalWithExponentBase i e Base10
+
+mkRationalWithExponentBase :: Integer -> Integer -> FractionalExponentBase -> Rational
+mkRationalWithExponentBase i e feb = (i :% 1) * (eb ^^ e)
+  where eb = case feb of Base2 -> 2 ; Base10 -> 10
+
+-- Note [fractional exponent bases] For hexadecimal rationals of
+-- the form 0x0.3p10 the exponent is given on base 2 rather than
+-- base 10. These are the only options, hence the sum type. See also #15646.
index cb73b42..5b8e2c0 100644 (file)
@@ -80,7 +80,7 @@
 
 (LiteralsTest.hs:15:3,ITequal,[=]),
 
-(LiteralsTest.hs:15:5-8,ITrational (FL {fl_text = SourceText "0.00", fl_neg = False, fl_value = 0 % 1}),[0.00]),
+(LiteralsTest.hs:15:5-8,ITrational (FL {fl_text = SourceText "0.00", fl_neg = False, fl_signi = 0, fl_exp = -2, fl_exp_base = Base10}),[0.00]),
 
 (LiteralsTest.hs:17:1,ITsemi,[]),
 
 
 (LiteralsTest.hs:22:12,ITequal,[=]),
 
-(LiteralsTest.hs:22:14-18,ITprimfloat (FL {fl_text = SourceText "3.20", fl_neg = False, fl_value = 16 % 5}),[3.20#]),
+(LiteralsTest.hs:22:14-18,ITprimfloat (FL {fl_text = SourceText "3.20", fl_neg = False, fl_signi = 320, fl_exp = -2, fl_exp_base = Base10}),[3.20#]),
 
 (LiteralsTest.hs:23:5,ITsemi,[]),
 
 
 (LiteralsTest.hs:23:13,ITequal,[=]),
 
-(LiteralsTest.hs:23:15-21,ITprimdouble (FL {fl_text = SourceText "04.16", fl_neg = False, fl_value = 104 % 25}),[04.16##]),
+(LiteralsTest.hs:23:15-21,ITprimdouble (FL {fl_text = SourceText "04.16", fl_neg = False, fl_signi = 416, fl_exp = -2, fl_exp_base = Base10}),[04.16##]),
 
 (LiteralsTest.hs:24:5,ITsemi,[]),
 
diff --git a/testsuite/tests/typecheck/should_compile/T15646.hs b/testsuite/tests/typecheck/should_compile/T15646.hs
new file mode 100644 (file)
index 0000000..0e106e3
--- /dev/null
@@ -0,0 +1,3 @@
+module T15646 where
+
+f = 1e123456789
\ No newline at end of file
index 9d8f905..465d68a 100644 (file)
@@ -671,3 +671,8 @@ test('T16204b', normal, compile, [''])
 test('T16225', normal, compile, [''])
 test('T13951', normal, compile, [''])
 test('T16411', normal, compile, [''])
+test('T15646',
+     compile_timeout_multiplier(0.01),
+     # 0.01 may seem tiny (1 is timeout after 300s, so this is 3 seconds),
+     # but if this test regresses, it will take about 10 seconds to finish.
+     compile, [''])