Fix typechecking time bug for large rationals (#15646)wip/T15646

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.

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, [''])