Canonicalize bignum literals

Before this patch Integer and Natural literals were desugared into "real"
Core in Core prep. Now we desugar them directly into their final ConApp
form in HsToCore. We only keep the double representation for BigNat#
(literals larger than a machine Word/Int) which are still desugared in
Core prep.

Using the final form directly allows case-of-known-constructor to fire
for bignum literals, fixing #20245.

Slight increase (+2.3) in T4801 which is a pathological case with
Integer literals.

Metric Increase:
    T4801
    T11545

3 files changed, 51 insertions, 26 deletions

diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs
index c19dceabb8..95c4285422 100644
--- a/compiler/GHC/HsToCore/Match/Literal.hs
+++ b/compiler/GHC/HsToCore/Match/Literal.hs
@@ -108,7 +108,7 @@ dsLit l = do
     HsDoublePrim _ fl -> return (Lit (LitDouble (rationalFromFractionalLit fl)))
     HsChar _ c       -> return (mkCharExpr c)
     HsString _ str   -> mkStringExprFS str
-    HsInteger _ i _  -> return (mkIntegerExpr i)
+    HsInteger _ i _  -> return (mkIntegerExpr platform i)
     HsInt _ i        -> return (mkIntExpr platform (il_value i))
     HsRat _ fl ty    -> dsFractionalLitToRational fl ty
 
@@ -199,15 +199,17 @@ 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)
+  = do
+    platform <- targetPlatform <$> getDynFlags
+    let !val   = rationalFromFractionalLit fl
+        !num   = mkIntegerExpr platform (numerator val)
+        !denom = mkIntegerExpr platform (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])
+    return $! (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
   -- Large rationals will be computed at runtime.
   | otherwise
   = do
@@ -216,14 +218,16 @@ dsFractionalLitToRational fl@FL{ fl_signi = signi, fl_exp = exp, fl_exp_base = b
                              Base10 -> mkRationalBase10Name
       mkRational <- dsLookupGlobalId mkRationalName
       litR <- dsRational signi
-      let litE = mkIntegerExpr exp
+      platform <- targetPlatform <$> getDynFlags
+      let litE = mkIntegerExpr platform exp
       return (mkCoreApps (Var mkRational) [litR, litE])
 
 dsRational :: Rational -> DsM CoreExpr
 dsRational (n :% d) = do
+  platform <- targetPlatform <$> getDynFlags
   dcn <- dsLookupDataCon ratioDataConName
-  let cn = mkIntegerExpr n
-  let dn = mkIntegerExpr d
+  let cn = mkIntegerExpr platform n
+  let dn = mkIntegerExpr platform d
   return $ mkCoreConApps dcn [Type integerTy, cn, dn]
 
 
diff --git a/compiler/GHC/HsToCore/Pmc/Solver/Types.hs b/compiler/GHC/HsToCore/Pmc/Solver/Types.hs
index a111bbdd33..1fcaf44a4f 100644
--- a/compiler/GHC/HsToCore/Pmc/Solver/Types.hs
+++ b/compiler/GHC/HsToCore/Pmc/Solver/Types.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE ApplicativeDo       #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE ViewPatterns        #-}
+{-# LANGUAGE MultiWayIf          #-}
 
 -- | Domain types used in "GHC.HsToCore.Pmc.Solver".
 -- The ultimate goal is to define 'Nabla', which models normalised refinement
@@ -49,6 +50,7 @@ import GHC.Core.DataCon
 import GHC.Core.ConLike
 import GHC.Utils.Outputable
 import GHC.Utils.Panic.Plain
+import GHC.Utils.Misc (lastMaybe)
 import GHC.Data.List.SetOps (unionLists)
 import GHC.Data.Maybe
 import GHC.Core.Type
@@ -620,17 +622,24 @@ coreExprAsPmLit e = case collectArgs e of
     | Just dc <- isDataConWorkId_maybe x
     , dc `elem` [intDataCon, wordDataCon, charDataCon, floatDataCon, doubleDataCon]
     -> literalToPmLit (exprType e) l
-  (Var x, [_ty, Lit n, Lit d])
+  (Var x, [Lit (LitNumber _ l)])
+    | Just (ty,l) <- bignum_lit_maybe x l
+    -> Just (PmLit ty (PmLitInt l))
+  (Var x, [_ty, n_arg, d_arg])
     | Just dc <- isDataConWorkId_maybe x
     , dataConName dc == ratioDataConName
+    , Just (PmLit _ (PmLitInt n)) <- coreExprAsPmLit n_arg
+    , Just (PmLit _ (PmLitInt d)) <- coreExprAsPmLit d_arg
     -- HACK: just assume we have a literal double. This case only occurs for
     --       overloaded lits anyway, so we immediately override type information
-    -> literalToPmLit (exprType e) (mkLitDouble (litValue n % litValue d))
+    -> literalToPmLit (exprType e) (mkLitDouble (n % d))
+
   (Var x, args)
     -- See Note [Detecting overloaded literals with -XRebindableSyntax]
     | is_rebound_name x fromIntegerName
-    , [Lit l] <- dropWhile (not . is_lit) args
-    -> literalToPmLit (literalType l) l >>= overloadPmLit (exprType e)
+    , Just arg <- lastMaybe args
+    , Just (_ty,l) <- bignum_conapp_maybe arg
+    -> Just (PmLit integerTy (PmLitInt l)) >>= overloadPmLit (exprType e)
   (Var x, args)
     -- See Note [Detecting overloaded literals with -XRebindableSyntax]
     -- fromRational <expr>
@@ -644,16 +653,16 @@ coreExprAsPmLit e = case collectArgs e of
     -- 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
+    , [r, exp] <- dropWhile (not . is_ratio) args
+    , (Var x, [_ty, n_arg, d_arg]) <- collectArgs r
     , Just dc <- isDataConWorkId_maybe x
     , dataConName dc == ratioDataConName
+    , Just (PmLit _ (PmLitInt n)) <- coreExprAsPmLit n_arg
+    , Just (PmLit _ (PmLitInt d)) <- coreExprAsPmLit d_arg
+    , Just (_exp_ty,exp') <- bignum_conapp_maybe exp
     -> 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 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)
 
@@ -675,8 +684,20 @@ coreExprAsPmLit e = case collectArgs e of
 
   _ -> Nothing
   where
-    is_lit Lit{} = True
-    is_lit _     = False
+    bignum_conapp_maybe (App (Var x) (Lit (LitNumber _ l)))
+      = bignum_lit_maybe x l
+    bignum_conapp_maybe _ = Nothing
+
+    bignum_lit_maybe x l
+      | Just dc <- isDataConWorkId_maybe x
+      = if | dc == integerISDataCon -> Just (integerTy,l)
+           | dc == integerIPDataCon -> Just (integerTy,l)
+           | dc == integerINDataCon -> Just (integerTy,negate l)
+           | dc == naturalNSDataCon -> Just (naturalTy,l)
+           | dc == naturalNBDataCon -> Just (naturalTy,l)
+           | otherwise              -> Nothing
+    bignum_lit_maybe _ _ = Nothing
+
     is_ratio (Type _) = False
     is_ratio r
       | Just (tc, _) <- splitTyConApp_maybe (exprType r)
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index ea185b076f..032c003c6a 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -1422,7 +1422,9 @@ repTy (HsIParamTy _ n t) = do
 repTy ty                      = notHandled (ThExoticFormOfType ty)
 
 repTyLit :: HsTyLit -> MetaM (Core (M TH.TyLit))
-repTyLit (HsNumTy _ i) = rep2 numTyLitName [mkIntegerExpr i]
+repTyLit (HsNumTy _ i) = do
+                         platform <- getPlatform
+                         rep2 numTyLitName [mkIntegerExpr platform i]
 repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
                             ; rep2 strTyLitName [s']
                             }
@@ -2174,7 +2176,8 @@ globalVar name
         ; rep2_nwDsM mk_varg [pkg,mod,occ] }
   | otherwise
   = do  { MkC occ <- nameLit name
-        ; MkC uni <- coreIntegerLit (toInteger $ getKey (getUnique name))
+        ; platform <- targetPlatform <$> getDynFlags
+        ; let uni = mkIntegerExpr platform (toInteger $ getKey (getUnique name))
         ; rep2_nwDsM mkNameLName [occ,uni] }
   where
       mod = assert (isExternalName name) nameModule name
@@ -3035,9 +3038,6 @@ coreIntLit :: Int -> MetaM (Core Int)
 coreIntLit i = do platform <- getPlatform
                   return (MkC (mkIntExprInt platform i))
 
-coreIntegerLit :: MonadThings m => Integer -> m (Core Integer)
-coreIntegerLit i = pure (MkC (mkIntegerExpr i))
-
 coreVar :: Id -> Core TH.Name   -- The Id has type Name
 coreVar id = MkC (Var id)