summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndreas Klebinger <klebinger.andreas@gmx.at>2021-01-20 16:24:14 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-02-27 08:00:08 -0500
commit60bf4d7ca59e333db6349948b8140651d0190004 (patch)
tree706809fce670feb8b5799bebbf95c379593ec2f3
parent966a768e9b99e72c9d98a1c971427044888d6de9 (diff)
downloadhaskell-60bf4d7ca59e333db6349948b8140651d0190004.tar.gz
Fix typechecking time bug for large rationals (#15646)
When desugaring large overloaded literals we now avoid computing the `Rational` value. Instead prefering to store the significant and exponent as given where reasonable and possible. See Note [FractionalLit representation] for details.
-rw-r--r--compiler/GHC/Builtin/Names.hs15
-rw-r--r--compiler/GHC/Builtin/Types.hs2
-rw-r--r--compiler/GHC/HsToCore/Match.hs20
-rw-r--r--compiler/GHC/HsToCore/Match/Literal.hs146
-rw-r--r--compiler/GHC/HsToCore/Pmc/Desugar.hs34
-rw-r--r--compiler/GHC/HsToCore/Pmc/Solver/Types.hs72
-rw-r--r--compiler/GHC/Parser/Lexer.x28
-rw-r--r--compiler/GHC/Rename/Pat.hs21
-rw-r--r--compiler/GHC/Tc/Utils/Zonk.hs12
-rw-r--r--compiler/GHC/ThToHs.hs6
-rw-r--r--compiler/GHC/Types/Literal.hs1
-rw-r--r--compiler/GHC/Types/SourceText.hs131
-rw-r--r--compiler/GHC/Utils/Misc.hs110
-rw-r--r--libraries/base/GHC/Real.hs19
-rw-r--r--testsuite/tests/ghc-api/annotations-literals/literals.stdout6
-rw-r--r--testsuite/tests/pmcheck/should_compile/T19384.hs34
-rw-r--r--testsuite/tests/pmcheck/should_compile/all.T5
-rw-r--r--testsuite/tests/typecheck/should_compile/T15646.hs7
-rw-r--r--testsuite/tests/typecheck/should_compile/all.T5
19 files changed, 573 insertions, 101 deletions
diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs
index fc0589730a..563ccbf57e 100644
--- a/compiler/GHC/Builtin/Names.hs
+++ b/compiler/GHC/Builtin/Names.hs
@@ -266,6 +266,7 @@ basicKnownKeyNames
-- Numeric stuff
negateName, minusName, geName, eqName,
+ mkRationalBase2Name, mkRationalBase10Name,
-- Conversion functions
rationalTyConName,
@@ -1340,7 +1341,7 @@ integerShiftRName = bniVarQual "integerShiftR#" integerShiftR
rationalTyConName, ratioTyConName, ratioDataConName, realClassName,
integralClassName, realFracClassName, fractionalClassName,
fromRationalName, toIntegerName, toRationalName, fromIntegralName,
- realToFracName :: Name
+ realToFracName, mkRationalBase2Name, mkRationalBase10Name :: Name
rationalTyConName = tcQual gHC_REAL (fsLit "Rational") rationalTyConKey
ratioTyConName = tcQual gHC_REAL (fsLit "Ratio") ratioTyConKey
ratioDataConName = dcQual gHC_REAL (fsLit ":%") ratioDataConKey
@@ -1353,7 +1354,8 @@ toIntegerName = varQual gHC_REAL (fsLit "toInteger") toIntegerClassOpKe
toRationalName = varQual gHC_REAL (fsLit "toRational") toRationalClassOpKey
fromIntegralName = varQual gHC_REAL (fsLit "fromIntegral")fromIntegralIdKey
realToFracName = varQual gHC_REAL (fsLit "realToFrac") realToFracIdKey
-
+mkRationalBase2Name = varQual gHC_REAL (fsLit "mkRationalBase2") mkRationalBase2IdKey
+mkRationalBase10Name = varQual gHC_REAL (fsLit "mkRationalBase10") mkRationalBase10IdKey
-- PrelFloat classes
floatingClassName, realFloatClassName :: Name
floatingClassName = clsQual gHC_FLOAT (fsLit "Floating") floatingClassKey
@@ -2711,6 +2713,15 @@ naturalSizeInBaseIdKey = mkPreludeMiscIdUnique 684
bignatFromWordListIdKey = mkPreludeMiscIdUnique 690
+------------------------------------------------------
+-- ghci optimization for big rationals 700-749 uniques
+------------------------------------------------------
+
+-- Creating rationals at runtime.
+mkRationalBase2IdKey, mkRationalBase10IdKey :: Unique
+mkRationalBase2IdKey = mkPreludeMiscIdUnique 700
+mkRationalBase10IdKey = mkPreludeMiscIdUnique 701 :: Unique
+
{-
************************************************************************
* *
diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs
index 924ce6648d..1a3550fcaa 100644
--- a/compiler/GHC/Builtin/Types.hs
+++ b/compiler/GHC/Builtin/Types.hs
@@ -1959,8 +1959,6 @@ extractPromotedList tys = go tys
| otherwise
= pprPanic "extractPromotedList" (ppr tys)
-
-
---------------------------------------
-- ghc-bignum
---------------------------------------
diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs
index 8576197d4d..425940624b 100644
--- a/compiler/GHC/HsToCore/Match.hs
+++ b/compiler/GHC/HsToCore/Match.hs
@@ -902,7 +902,7 @@ data PatGroup
| PgCon DataCon -- Constructor patterns (incl list, tuple)
| PgSyn PatSyn [Type] -- See Note [Pattern synonym groups]
| PgLit Literal -- Literal patterns
- | PgN Rational -- Overloaded numeric literals;
+ | PgN FractionalLit -- Overloaded numeric literals;
-- see Note [Don't use Literal for PgN]
| PgOverS FastString -- Overloaded string literals
| PgNpK Integer -- n+k patterns
@@ -930,7 +930,7 @@ 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
+the PgN constructor as a FractionalLit if numeric, and add a PgOverStr constructor
for overloaded strings.
-}
@@ -1016,6 +1016,10 @@ 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
+ -- Order is significant, match PgN after PgLit
+ -- If the exponents are small check for value equality rather than syntactic equality
+ -- This is implemented in the Eq instance for FractionalLit, we do this to avoid
+ -- computing the value of excessivly large rationals.
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
@@ -1162,12 +1166,12 @@ 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 (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
+ (HsIntegral i, is_neg) -> PgN (integralFractionalLit is_neg (il_value i))
+ (HsFractional f, is_neg)
+ | is_neg -> PgN $! negateFractionalLit f
+ | otherwise -> PgN f
+ (HsIsString _ s, _) -> ASSERT(isNothing mb_neg)
+ PgOverS s
patGroup _ (NPlusKPat _ _ (L _ (OverLit {ol_val=oval})) _ _ _) =
case oval of
HsIntegral i -> PgNpK (il_value i)
diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs
index f4021d2e29..218f2ef35b 100644
--- a/compiler/GHC/HsToCore/Match/Literal.hs
+++ b/compiler/GHC/HsToCore/Match/Literal.hs
@@ -52,7 +52,6 @@ import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
import GHC.Types.Literal
import GHC.Types.SrcLoc
-import Data.Ratio
import GHC.Utils.Outputable as Outputable
import GHC.Driver.Session
import GHC.Utils.Misc
@@ -66,6 +65,7 @@ import Data.Int
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NEL
import Data.Word
+import GHC.Real ( Ratio(..), numerator, denominator )
{-
************************************************************************
@@ -101,22 +101,131 @@ dsLit l = do
HsWordPrim _ w -> return (Lit (mkLitWordWrap platform w))
HsInt64Prim _ i -> return (Lit (mkLitInt64Wrap i))
HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap w))
- HsFloatPrim _ f -> return (Lit (LitFloat (fl_value f)))
- HsDoublePrim _ d -> return (Lit (LitDouble (fl_value d)))
+
+ -- This can be slow for very large literals. See Note [FractionalLit representation]
+ -- and #15646
+ 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 _ -> return (mkIntegerExpr i)
HsInt _ i -> return (mkIntExpr platform (il_value i))
- HsRat _ (FL _ _ val) ty ->
- return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
- where
- num = mkIntegerExpr (numerator val)
- denom = mkIntegerExpr (denominator val)
+ HsRat _ fl ty -> dsFractionalLitToRational fl ty
+
+{-
+Note [FractionalLit representation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There is a fun wrinkle to this, we used to simply compute the value
+for these literals and store it as `Rational`. While this might seem
+reasonable it meant typechecking literals of extremely large numbers
+wasn't possible. This happend for example in #15646.
+
+There a user would write in GHCi e.g. `:t 1e1234111111111111111111111`
+which would trip up the compiler. The reason being we would parse it as
+<Literal of value n>. Try to compute n, which would run out of memory
+for truly large numbers, or take far too long for merely large ones.
+
+To fix this we instead now store the significand and exponent of the
+literal instead. Depending on the size of the exponent we then defer
+the computation of the Rational value, potentially up to runtime of the
+program! There are still cases left were we might compute large rationals
+but it's a lot rarer then.
+
+The current state of affairs for large literals is:
+* Typechecking: Will produce a FractionalLit
+* Desugaring a large overloaded literal to Float/Double *is* done
+ at compile time. So can still fail. But this only matters for values too large
+ to be represented as float anyway.
+* Converting overloaded literals to a value of *Rational* is done at *runtime*.
+ If such a value is then demanded at runtime the program might hang or run out of
+ memory. But that is perhaps expected and acceptable.
+* TH might also evaluate the literal even when overloaded.
+ But there a user should be able to work around #15646 by
+ generating a call to `mkRationalBase10/2` for large literals instead.
+
+
+Note [FractionalLit representation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For fractional literals, like 1.3 or 0.79e22, we do /not/ represent
+them within the compiler as a Rational. Doing so would force the
+compiler to compute a huge Rational for 2.3e300000000000, at compile
+time (#15646)!
+
+So instead we represent fractional literals as a FractionalLit,
+in which we record the significand and exponent separately. Then
+we can compute the huge Rational at /runtime/, by emitting code
+for
+ mkRationalBase10 2.3 300000000000
+
+where mkRationalBase10 is defined in the library GHC.Real
+
+The moving parts are here:
+
+* Parsing, renaming, typechecking: use FractionalLit, in which the
+ significand and exponent are represented separately.
+
+* Desugaring. Remember that a fractional literal like 54.4e20 has type
+ Fractional a => a
+
+ - For fractional literals whose type turns out to be Float/Double,
+ we desugar to a Float/Double literal at /compile time/.
+ This conversion can still fail. But this only matters for values
+ too large to be represented as float anyway. See dsLit in
+ GHC.HsToCore.Match.Literal
+
+ - For fractional literals whose type turns out to be Rational, we
+ desugar the literal to a call of `mkRationalBase10` (etc for hex
+ literals), so that we only compute the Rational at /run time/. If
+ this value is then demanded at runtime the program might hang or
+ run out of memory. But that is perhaps expected and acceptable.
+ See dsFractionalLitToRational in GHC.HsToCore.Match.Literal
+
+ - For fractional literals whose type isn't one of the above, we just
+ call the typeclass method `fromRational`. But to do that we need
+ the rational to give to it, and we compute that at runtime, as
+ above.
+
+* Template Haskell definitions are also problematic. While the TH code
+ works as expected once it's spliced into a program it will compute the
+ value of the large literal.
+ But there a user should be able to work around #15646
+ by having their TH code generating a call to `mkRationalBase[10/2]` for
+ large literals instead.
+
+-}
+
+-- | See Note [FractionalLit representation]
+dsFractionalLitToRational :: FractionalLit -> Type -> DsM CoreExpr
+dsFractionalLitToRational fl@FL{ fl_signi = signi, fl_exp = exp, fl_exp_base = base } ty
+ -- We compute "small" rationals here and now
+ | abs exp <= 100
+ = let !val = rationalFromFractionalLit fl
+ !num = mkIntegerExpr (numerator val)
+ !denom = mkIntegerExpr (denominator val)
(ratio_data_con, integer_ty)
= case tcSplitTyConApp ty of
(tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
(head (tyConDataCons tycon), i_ty)
x -> pprPanic "dsLit" (ppr x)
+ in return $! (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
+ -- Large rationals will be computed at runtime.
+ | otherwise
+ = do
+ let mkRationalName = case base of
+ Base2 -> mkRationalBase2Name
+ Base10 -> mkRationalBase10Name
+ mkRational <- dsLookupGlobalId mkRationalName
+ litR <- dsRational signi
+ let litE = mkIntegerExpr exp
+ return (mkCoreApps (Var mkRational) [litR, litE])
+
+dsRational :: Rational -> DsM CoreExpr
+dsRational (n :% d) = do
+ dcn <- dsLookupDataCon ratioDataConName
+ let cn = mkIntegerExpr n
+ let dn = mkIntegerExpr d
+ return $ mkCoreConApps dcn [Type integerTy, cn, dn]
+
dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr
-- ^ Post-typechecker, the 'HsExpr' field of an 'OverLit' contains
@@ -128,6 +237,7 @@ dsOverLit (OverLit { ol_val = val, ol_ext = OverLitTc rebindable ty
case shortCutLit platform val ty of
Just expr | not rebindable -> dsExpr expr -- Note [Literal short cut]
_ -> dsExpr witness
+
{-
Note [Literal short cut]
~~~~~~~~~~~~~~~~~~~~~~~~
@@ -540,15 +650,17 @@ hsLitKey :: Platform -> 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 platform (HsIntPrim _ i) = mkLitIntWrap platform i
-hsLitKey platform (HsWordPrim _ w) = mkLitWordWrap platform w
-hsLitKey _ (HsInt64Prim _ i) = mkLitInt64Wrap i
-hsLitKey _ (HsWord64Prim _ w) = mkLitWord64Wrap 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 platform (HsIntPrim _ i) = mkLitIntWrap platform i
+hsLitKey platform (HsWordPrim _ w) = mkLitWordWrap platform w
+hsLitKey _ (HsInt64Prim _ i) = mkLitInt64Wrap i
+hsLitKey _ (HsWord64Prim _ w) = mkLitWord64Wrap w
+hsLitKey _ (HsCharPrim _ c) = mkLitChar c
+-- This following two can be slow. See Note [FractionalLit representation]
+hsLitKey _ (HsFloatPrim _ fl) = mkLitFloat (rationalFromFractionalLit fl)
+hsLitKey _ (HsDoublePrim _ fl) = mkLitDouble (rationalFromFractionalLit fl)
+
+hsLitKey _ (HsString _ s) = LitString (bytesFS s)
+hsLitKey _ l = pprPanic "hsLitKey" (ppr l)
{-
************************************************************************
diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs
index 1abe0fc9dc..f69600bf04 100644
--- a/compiler/GHC/HsToCore/Pmc/Desugar.hs
+++ b/compiler/GHC/HsToCore/Pmc/Desugar.hs
@@ -29,6 +29,7 @@ import GHC.Types.Id
import GHC.Core.ConLike
import GHC.Types.Name
import GHC.Builtin.Types
+import GHC.Builtin.Names (rationalTyConName)
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -47,12 +48,14 @@ import GHC.Core.Type
import GHC.Data.Maybe
import qualified GHC.LanguageExtensions as LangExt
import GHC.Utils.Monad (concatMapM)
-
+import GHC.Types.SourceText (FractionalLit(..))
import Control.Monad (zipWithM)
import Data.List (elemIndex)
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.List.NonEmpty as NE
+-- import GHC.Driver.Ppr
+
-- | Smart constructor that eliminates trivial lets
mkPmLetVar :: Id -> Id -> [PmGrd]
mkPmLetVar x y | x == y = []
@@ -199,13 +202,34 @@ desugarPat x pat = case pat of
-- short cutting in dsOverLit works properly) is overloaded iff either is.
dflags <- getDynFlags
let platform = targetPlatform dflags
- core_expr <- case olit of
+ pm_lit <- case olit of
OverLit{ ol_val = val, ol_ext = OverLitTc rebindable _ }
| not rebindable
, Just expr <- shortCutLit platform val ty
- -> dsExpr expr
- _ -> dsOverLit olit
- let lit = expectJust "failed to detect OverLit" (coreExprAsPmLit core_expr)
+ -> coreExprAsPmLit <$> dsExpr expr
+ | not rebindable
+ , (HsFractional f) <- val
+ , negates <- if fl_neg f then 1 else 0
+ -> do
+ rat_tc <- dsLookupTyCon rationalTyConName
+ let rat_ty = mkTyConTy rat_tc
+ return $ Just $ PmLit rat_ty (PmLitOverRat negates f)
+ | otherwise
+ -> do
+ dsLit <- dsOverLit olit
+ let !pmLit = coreExprAsPmLit dsLit :: Maybe PmLit
+ -- pprTraceM "desugarPat"
+ -- (
+ -- text "val" <+> ppr val $$
+ -- text "witness" <+> ppr (ol_witness olit) $$
+ -- text "dsLit" <+> ppr dsLit $$
+ -- text "asPmLit" <+> ppr pmLit
+ -- )
+ return pmLit
+
+ let lit = case pm_lit of
+ Just l -> l
+ Nothing -> pprPanic "failed to detect OverLit" (ppr olit)
let lit' = case mb_neg of
Just _ -> expectJust "failed to negate lit" (negatePmLit lit)
Nothing -> lit
diff --git a/compiler/GHC/HsToCore/Pmc/Solver/Types.hs b/compiler/GHC/HsToCore/Pmc/Solver/Types.hs
index 26a2eaef79..1e4e672583 100644
--- a/compiler/GHC/HsToCore/Pmc/Solver/Types.hs
+++ b/compiler/GHC/HsToCore/Pmc/Solver/Types.hs
@@ -62,12 +62,17 @@ import GHC.Builtin.Types.Prim
import GHC.Tc.Solver.Monad (InertSet, emptyInert)
import GHC.Tc.Utils.TcType (isStringTy)
import GHC.Types.CompleteMatch (CompleteMatch)
+import GHC.Types.SourceText (mkFractionalLit, FractionalLit, fractionalLitFromRational,
+ FractionalExponentBase(..), SourceText(..))
import Numeric (fromRat)
import Data.Foldable (find)
import Data.Ratio
+import GHC.Real (Ratio(..))
import qualified Data.Semigroup as Semi
+-- import GHC.Driver.Ppr
+
--
-- * Normalised refinement types
--
@@ -293,7 +298,7 @@ data PmLitValue
-- lists
| PmLitString FastString
| PmLitOverInt Int {- How often Negated? -} Integer
- | PmLitOverRat Int {- How often Negated? -} Rational
+ | PmLitOverRat Int {- How often Negated? -} FractionalLit
| PmLitOverString FastString
-- | Undecidable semantic equality result.
@@ -523,10 +528,11 @@ overloadPmLit :: Type -> PmLit -> Maybe PmLit
overloadPmLit ty (PmLit _ v) = PmLit ty <$> go v
where
go (PmLitInt i) = Just (PmLitOverInt 0 i)
- go (PmLitRat r) = Just (PmLitOverRat 0 r)
+ go (PmLitRat r) = Just $! PmLitOverRat 0 $! fractionalLitFromRational r
go (PmLitString s)
| ty `eqType` stringTy = Just v
| otherwise = Just (PmLitOverString s)
+ go ovRat@PmLitOverRat{} = Just ovRat
go _ = Nothing
pmLitAsStringLit :: PmLit -> Maybe FastString
@@ -555,9 +561,30 @@ coreExprAsPmLit e = case collectArgs e of
-> literalToPmLit (literalType l) l >>= overloadPmLit (exprType e)
(Var x, args)
-- See Note [Detecting overloaded literals with -XRebindableSyntax]
+ -- fromRational <expr>
| is_rebound_name x fromRationalName
, [r] <- dropWhile (not . is_ratio) args
-> coreExprAsPmLit r >>= overloadPmLit (exprType e)
+
+ --Rationals with large exponents
+ (Var x, args)
+ -- See Note [Detecting overloaded literals with -XRebindableSyntax]
+ -- See Note [Dealing with rationals with large exponents]
+ -- mkRationalBase* <rational> <exponent>
+ | Just exp_base <- is_larg_exp_ratio x
+ , [r, Lit exp] <- dropWhile (not . is_ratio) args
+ , (Var x, [_ty, Lit n, Lit d]) <- collectArgs r
+ , Just dc <- isDataConWorkId_maybe x
+ , dataConName dc == ratioDataConName
+ -> do
+ n' <- isLitValue_maybe n
+ d' <- isLitValue_maybe d
+ exp' <- isLitValue_maybe exp
+ let rational = (abs n') :% d'
+ let neg = if n' < 0 then 1 else 0
+ let frac = mkFractionalLit NoSourceText False rational exp' exp_base
+ Just $ PmLit (exprType e) (PmLitOverRat neg frac)
+
(Var x, args)
| is_rebound_name x fromStringName
-- See Note [Detecting overloaded literals with -XRebindableSyntax]
@@ -573,6 +600,7 @@ coreExprAsPmLit e = case collectArgs e of
(Var x, [Lit l])
| idName x `elem` [unpackCStringName, unpackCStringUtf8Name]
-> literalToPmLit stringTy l
+
_ -> Nothing
where
is_lit Lit{} = True
@@ -583,6 +611,14 @@ coreExprAsPmLit e = case collectArgs e of
= tyConName tc == ratioTyConName
| otherwise
= False
+ is_larg_exp_ratio x
+ | is_rebound_name x mkRationalBase10Name
+ = Just Base10
+ | is_rebound_name x mkRationalBase2Name
+ = Just Base2
+ | otherwise
+ = Nothing
+
-- See Note [Detecting overloaded literals with -XRebindableSyntax]
is_rebound_name :: Id -> Name -> Bool
@@ -601,6 +637,36 @@ type `String`).
The same applies to other overloaded literals, such as overloaded rationals
(`fromRational`)and overloaded integer literals (`fromInteger`).
+
+Note [Dealing with rationals with large exponents]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Rationals with large exponents are *not* desugared to
+a simple rational. As that would require us to compute
+their value which can be expensive. Rather they desugar
+to an expression. For example 1e1000 will desugar to an
+expression of the form: `mkRationalWithExponentBase10 (1 :% 1) 1000`
+
+Only overloaded literals desugar to this form however, so we
+we can just return a overloaded rational literal.
+
+The most complex case is if we have RebindableSyntax enabled.
+By example if we have a pattern like this: `f 3.3 = True`
+
+It will desugar to:
+ fromRational
+ [TYPE: Rational, mkRationalBase10 (:% @Integer 10 1) (-1)]
+
+The fromRational is properly detected as an overloaded Rational by
+coreExprAsPmLit and it's general code for detecting overloaded rationals.
+See Note [Detecting overloaded literals with -XRebindableSyntax].
+
+This case then recurses into coreExprAsPmLit passing only the expression
+`mkRationalBase10 (:% @Integer 10 1) (-1)`. Which is caught by rationals
+with large exponents case. This will return a `PmLitOverRat` literal.
+
+Which is then passed to overloadPmLit which simply returns it as-is since
+it's already overloaded.
+
-}
instance Outputable PmLitValue where
@@ -609,7 +675,7 @@ instance Outputable PmLitValue where
ppr (PmLitChar c) = pprHsChar c
ppr (PmLitString s) = pprHsString s
ppr (PmLitOverInt n i) = minuses n (ppr i)
- ppr (PmLitOverRat n r) = minuses n (ppr (double (fromRat r)))
+ ppr (PmLitOverRat n r) = minuses n (ppr r)
ppr (PmLitOverString s) = pprHsString s
-- Take care of negated literals
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index 5e2af15f96..b7a3daced5 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -101,7 +101,7 @@ import GHC.Data.FastString
import GHC.Types.Unique.FM
import GHC.Data.Maybe
import GHC.Data.OrdList
-import GHC.Utils.Misc ( readRational, readHexRational )
+import GHC.Utils.Misc ( readSignificandExponentPair, readHexSignificandExponentPair )
import GHC.Types.SrcLoc
import GHC.Types.SourceText
@@ -1700,7 +1700,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
@@ -1716,18 +1716,20 @@ tok_hex_float str = ITrational $! readHexFractionalLit str
tok_primfloat str = ITprimfloat $! readFractionalLit str
tok_primdouble str = ITprimdouble $! readFractionalLit str
-readFractionalLit :: String -> FractionalLit
-readFractionalLit str = ((FL $! (SourceText str)) $! is_neg) $! readRational str
- where is_neg = case str of ('-':_) -> True
- _ -> False
-readHexFractionalLit :: String -> FractionalLit
-readHexFractionalLit str =
- FL { fl_text = SourceText str
- , fl_neg = case str of
+readFractionalLit, readHexFractionalLit :: String -> FractionalLit
+readHexFractionalLit = readFractionalLitX readHexSignificandExponentPair Base2
+readFractionalLit = readFractionalLitX readSignificandExponentPair Base10
+
+readFractionalLitX :: (String -> (Integer, Integer))
+ -> FractionalExponentBase
+ -> String -> FractionalLit
+readFractionalLitX readStr b str =
+ mkSourceFractionalLit str is_neg i e b
+ where
+ is_neg = case str of
'-' : _ -> True
- _ -> False
- , fl_value = readHexRational str
- }
+ _ -> False
+ (i, e) = readStr str
-- -----------------------------------------------------------------------------
-- Layout processing
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index a1bd52be3f..f911d9b0d7 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -848,21 +848,26 @@ rnLit :: HsLit p -> RnM ()
rnLit (HsChar _ c) = checkErr (inCharRange c) (bogusCharError c)
rnLit _ = return ()
--- Turn a Fractional-looking literal which happens to be an integer into an
+-- | Turn a Fractional-looking literal which happens to be an integer into an
-- Integer-looking literal.
+-- We only convert numbers where the exponent is between 0 and 100 to avoid
+-- converting huge numbers and incurring long compilation times. See #15646.
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 >= -100 && e <= 100
+ , let val = rationalFromFractionalLit fl
+ , denominator val == 1 = HsIntegral (IL {il_text=src,il_neg=neg,il_value=numerator val})
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 -> 0 == fl_signi fl && fl_neg fl
+ _ -> False
{-
Note [Negative zero]
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index aad5299bbf..4d4860c7e1 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -214,9 +214,15 @@ shortCutLit platform val res_ty
-- literals, compiled without -O
go_fractional f
- | isFloatTy res_ty = Just (mkLit floatDataCon (HsFloatPrim noExtField f))
- | isDoubleTy res_ty = Just (mkLit doubleDataCon (HsDoublePrim noExtField f))
- | otherwise = Nothing
+ | isFloatTy res_ty && valueInRange = Just (mkLit floatDataCon (HsFloatPrim noExtField f))
+ | isDoubleTy res_ty && valueInRange = Just (mkLit doubleDataCon (HsDoublePrim noExtField f))
+ | otherwise = Nothing
+ where
+ valueInRange =
+ case f of
+ FL { fl_exp = e } -> (-100) <= e && e <= 100
+ -- We limit short-cutting Fractional Literals to when their power of 10
+ -- is less than 100, which ensures desugaring isn't slow.
go_string src s
| isStringTy res_ty = Just (HsLit noExtField (HsString src s))
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 2a6442cab7..e78dac205d 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -1211,7 +1211,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'
@@ -1246,9 +1246,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 noExtField (mkFractionalLit f) }
+ = do { force f; return $ HsFloatPrim noExtField (mkTHFractionalLit f) }
cvtLit (DoublePrimL f)
- = do { force f; return $ HsDoublePrim noExtField (mkFractionalLit f) }
+ = do { force f; return $ HsDoublePrim noExtField (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 }
diff --git a/compiler/GHC/Types/Literal.hs b/compiler/GHC/Types/Literal.hs
index 23023fd421..470828476d 100644
--- a/compiler/GHC/Types/Literal.hs
+++ b/compiler/GHC/Types/Literal.hs
@@ -51,6 +51,7 @@ module GHC.Types.Literal
, isZeroLit, isOneLit
, litFitsInChar
, litValue, mapLitValue
+ , isLitValue_maybe
-- ** Coercions
, narrowInt8Lit, narrowInt16Lit, narrowInt32Lit
diff --git a/compiler/GHC/Types/SourceText.hs b/compiler/GHC/Types/SourceText.hs
index 320abbea27..3cce33a803 100644
--- a/compiler/GHC/Types/SourceText.hs
+++ b/compiler/GHC/Types/SourceText.hs
@@ -15,8 +15,14 @@ module GHC.Types.SourceText
, negateIntegralLit
, negateFractionalLit
, mkIntegralLit
+ , mkTHFractionalLit, rationalFromFractionalLit
+ , integralFractionalLit, mkSourceFractionalLit
+ , FractionalExponentBase(..)
+
+ -- Used by the pm checker.
+ , fractionalLitFromRational
, mkFractionalLit
- , integralFractionalLit
+
)
where
@@ -30,6 +36,7 @@ import GHC.Utils.Panic
import Data.Function (on)
import Data.Data
+import GHC.Real ( Ratio(..) )
{-
Note [Pragma source text]
@@ -155,37 +162,88 @@ negateIntegralLit (IL text neg value)
-- 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.
+-- Note [FractionalLit representation] in GHC.HsToCore.Match.Literal
+-- The actual value then is: sign * fl_signi * (fl_exp_base^fl_exp)
+-- where sign = if fl_neg then (-1) else 1
+--
+-- For example FL { fl_neg = True, fl_signi = 5.3, fl_exp = 4, fl_exp_base = Base10 }
+-- denotes -5300
+
data FractionalLit = FL
- { fl_text :: SourceText -- ^ How the value was written in the source
- , fl_neg :: Bool -- ^ See Note [Negative zero] in GHC.Rename.Pat
- , fl_value :: Rational -- ^ Numeric value of the literal
- }
- deriving (Data, Show)
+ { fl_text :: SourceText -- ^ How the value was written in the source
+ , fl_neg :: Bool -- See Note [Negative zero]
+ , fl_signi :: Rational -- The significand component of the literal
+ , fl_exp :: Integer -- The exponent component of the literal
+ , fl_exp_base :: FractionalExponentBase -- See Note [Fractional exponent bases]
+ }
+ deriving (Data, Show)
-- The Show instance is required for the derived GHC.Parser.Lexer.Token instance when DEBUG is on
-mkFractionalLit :: Real a => a -> FractionalLit
-mkFractionalLit r = FL { fl_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.)
- , fl_neg = r < 0
- , fl_value = toRational r }
+-- See Note [FractionalLit representation] in GHC.HsToCore.Match.Literal
+data FractionalExponentBase
+ = Base2 -- Used in hex fractional literals
+ | Base10
+ deriving (Eq, Ord, Data, Show)
+
+mkFractionalLit :: SourceText -> Bool -> Rational -> Integer -> FractionalExponentBase
+ -> FractionalLit
+mkFractionalLit = FL
+
+mkRationalWithExponentBase :: Rational -> Integer -> FractionalExponentBase -> Rational
+mkRationalWithExponentBase i e feb = i * (eb ^^ e)
+ where eb = case feb of Base2 -> 2 ; Base10 -> 10
+
+fractionalLitFromRational :: Rational -> FractionalLit
+fractionalLitFromRational r = FL { fl_text = NoSourceText
+ , fl_neg = r < 0
+ , fl_signi = r
+ , fl_exp = 0
+ , fl_exp_base = Base10 }
+
+rationalFromFractionalLit :: FractionalLit -> Rational
+rationalFromFractionalLit (FL _ _ i e expBase) =
+ mkRationalWithExponentBase i e expBase
+
+mkTHFractionalLit :: Rational -> FractionalLit
+mkTHFractionalLit r = FL { fl_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.)
+ , fl_neg = r < 0
+ , fl_signi = r
+ , fl_exp = 0
+ , fl_exp_base = Base10 }
negateFractionalLit :: FractionalLit -> FractionalLit
-negateFractionalLit (FL text neg value)
+negateFractionalLit (FL text neg i e eb)
= 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) -> 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
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 :% 1
+ , fl_exp = 0
+ , fl_exp_base = Base10 }
+
+mkSourceFractionalLit :: String -> Bool -> Integer -> Integer
+ -> FractionalExponentBase
+ -> FractionalLit
+mkSourceFractionalLit !str !b !r !i !ff = FL (SourceText str) b (r :% 1) i ff
+
+{- 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 GHC.HsToCore.Match.Literal)
@@ -200,14 +258,33 @@ instance Outputable IntegralLit where
ppr (IL (SourceText src) _ _) = text src
ppr (IL NoSourceText _ value) = text (show value)
+
+-- | Compare fractional lits with small exponents for value equality but
+-- large values for syntactic equality.
+compareFractionalLit :: FractionalLit -> FractionalLit -> Ordering
+compareFractionalLit fl1 fl2
+ | fl_exp fl1 < 100 && fl_exp fl2 < 100 && fl_exp fl1 >= -100 && fl_exp fl2 >= -100
+ = rationalFromFractionalLit fl1 `compare` rationalFromFractionalLit fl2
+ | otherwise = (compare `on` (\x -> (fl_signi x, fl_exp x, fl_exp_base x))) fl1 fl2
+
+-- | Be wary of using this instance to compare for equal *values* when exponents are
+-- large. The same value expressed in different syntactic form won't compare as equal when
+-- any of the exponents is >= 100.
instance Eq FractionalLit where
- (==) = (==) `on` fl_value
+ (==) fl1 fl2 = case compare fl1 fl2 of
+ EQ -> True
+ _ -> False
+-- | Be wary of using this instance to compare for equal *values* when exponents are
+-- large. The same value expressed in different syntactic form won't compare as equal when
+-- any of the exponents is >= 100.
instance Ord FractionalLit where
- compare = compare `on` fl_value
+ compare = compareFractionalLit
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)
-- | A String Literal in the source, including its original raw format for use by
-- source to source manipulation tools.
diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs
index 46fb352e61..f7168190e4 100644
--- a/compiler/GHC/Utils/Misc.hs
+++ b/compiler/GHC/Utils/Misc.hs
@@ -99,7 +99,9 @@ module GHC.Utils.Misc (
-- * Floating point
readRational,
+ readSignificandExponentPair,
readHexRational,
+ readHexSignificandExponentPair,
-- * IO-ish utilities
doesDirNameExist,
@@ -1161,9 +1163,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
@@ -1197,17 +1218,25 @@ 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
+-- | Parse a string into a significand and exponent.
+-- A trivial example might be:
+-- ghci> readSignificandExponentPair "1E2"
+-- (1,2)
+-- In a more complex case we might return a exponent different than that
+-- which the user wrote. This is needed in order to use a Integer significand.
+-- ghci> readSignificandExponentPair "-1.11E5"
+-- (-111,3)
+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
@@ -1265,6 +1294,73 @@ readHexRational__ ('0' : x : rest)
readHexRational__ _ = Nothing
+-- | Parse a string into a significand and exponent according to
+-- the "Hexadecimal Floats in Haskell" proposal.
+-- A trivial example might be:
+-- ghci> readHexSignificandExponentPair "0x1p+1"
+-- (1,1)
+-- Behaves similar to readSignificandExponentPair but the base is 16
+-- and numbers are given in hexadecimal:
+-- ghci> readHexSignificandExponentPair "0xAp-4"
+-- (10,-4)
+-- ghci> readHexSignificandExponentPair "0x1.2p3"
+-- (18,-1)
+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
+
+
-----------------------------------------------------------------------------
-- Verify that the 'dirname' portion of a FilePath exists.
--
diff --git a/libraries/base/GHC/Real.hs b/libraries/base/GHC/Real.hs
index 4329bb7355..696cb8a52e 100644
--- a/libraries/base/GHC/Real.hs
+++ b/libraries/base/GHC/Real.hs
@@ -817,3 +817,22 @@ 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 :: Rational -> Integer -> Rational
+mkRationalBase2 r e = mkRationalWithExponentBase r e Base2
+
+mkRationalBase10 :: Rational -> Integer -> Rational
+mkRationalBase10 r e = mkRationalWithExponentBase r e Base10
+
+mkRationalWithExponentBase :: Rational -> Integer
+ -> FractionalExponentBase -> Rational
+mkRationalWithExponentBase r e feb = r * (eb ^^ e)
+ -- See Note [fractional exponent bases] for why only these bases.
+ where eb = case feb of Base2 -> 2 ; Base10 -> 10
diff --git a/testsuite/tests/ghc-api/annotations-literals/literals.stdout b/testsuite/tests/ghc-api/annotations-literals/literals.stdout
index cb73b42d4f..501a5af5f3 100644
--- a/testsuite/tests/ghc-api/annotations-literals/literals.stdout
+++ b/testsuite/tests/ghc-api/annotations-literals/literals.stdout
@@ -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 % 1, fl_exp = -2, fl_exp_base = Base10}),[0.00]),
(LiteralsTest.hs:17:1,ITsemi,[]),
@@ -122,7 +122,7 @@
(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 % 1, fl_exp = -2, fl_exp_base = Base10}),[3.20#]),
(LiteralsTest.hs:23:5,ITsemi,[]),
@@ -130,7 +130,7 @@
(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 % 1, fl_exp = -2, fl_exp_base = Base10}),[04.16##]),
(LiteralsTest.hs:24:5,ITsemi,[]),
diff --git a/testsuite/tests/pmcheck/should_compile/T19384.hs b/testsuite/tests/pmcheck/should_compile/T19384.hs
new file mode 100644
index 0000000000..1cecffa8ad
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T19384.hs
@@ -0,0 +1,34 @@
+{-# OPTIONS_GHC -Wno-missing-methods #-}
+
+-- Pattern match checking is broken for overloaded rationals currently.
+
+module T15646a where
+
+
+foo_small :: ()
+foo_small = case 2e2 :: Rational of
+ 2e1 -> () -- redundant
+ 2e2 -> ()
+
+-- Large exponents are handled differently so we have an extra check.
+foo :: ()
+foo = case 2e102 :: Rational of
+ 2e101 -> () -- redundant
+ 2e102 -> ()
+
+-- Any literal of type T will desugar to the same value MkT.
+-- Eg. (1.0 :: T) == MkT
+data T = MkT deriving Eq
+instance Num T where
+instance Fractional T where
+ fromRational _ = MkT
+
+bar :: ()
+bar = case 2e102 :: T of
+ 2e101 -> () -- not redundant, pattern evaluates to MkT
+ 2e102 -> () -- redundant, pattern also evaluates to MkT
+
+baz :: ()
+baz = case 2e1 :: T of
+ 2e1 -> () -- not redundant, pattern evaluates to MkT
+ 2e2 -> () -- redundant, pattern also evaluates to MkT
diff --git a/testsuite/tests/pmcheck/should_compile/all.T b/testsuite/tests/pmcheck/should_compile/all.T
index 40b59b2fd3..b922696fae 100644
--- a/testsuite/tests/pmcheck/should_compile/all.T
+++ b/testsuite/tests/pmcheck/should_compile/all.T
@@ -252,3 +252,8 @@ test('EmptyCase009', [], compile,
['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
test('EmptyCase010', [], compile,
['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
+
+# Overloaded patterns and rational pattern matching being broken.
+test('T19384',
+ expect_broken(19384),
+ compile, [''])
diff --git a/testsuite/tests/typecheck/should_compile/T15646.hs b/testsuite/tests/typecheck/should_compile/T15646.hs
new file mode 100644
index 0000000000..27c9f71dcf
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T15646.hs
@@ -0,0 +1,7 @@
+module T15646 where
+
+f = 1e123456789
+
+g 1e123456789 = 1 :: Int
+g 2e123456789 = 2
+g (-2e123456789) = 3
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 46f2d088d1..68d5f21f49 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -664,6 +664,11 @@ test('T15499', normal, compile, [''])
test('T15586', normal, compile, [''])
test('T15368', normal, compile, ['-fdefer-type-errors'])
test('T15645', normal, compile, ['-Wwarn=missing-monadfail-instances'])
+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, [''])
test('T15778', normal, compile, [''])
test('T14761c', expect_broken_for(16540, ['hpc', 'profasm', 'optasm']), compile, [''])
test('T16008', normal, compile, [''])