summaryrefslogtreecommitdiff
path: root/compiler/GHC/HsToCore
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/HsToCore')
-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
4 files changed, 239 insertions, 33 deletions
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
View Lorry Controller Status