diff options
24 files changed, 266 insertions, 248 deletions
diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs index da03d2a903..1d7402c9cf 100644 --- a/compiler/GHC/ByteCode/Asm.hs +++ b/compiler/GHC/ByteCode/Asm.hs @@ -488,8 +488,7 @@ assembleI platform i = case i of LitNumWord32 -> int32 (fromIntegral i) LitNumInt64 -> int64 (fromIntegral i) LitNumWord64 -> int64 (fromIntegral i) - LitNumInteger -> panic "GHC.ByteCode.Asm.literal: LitNumInteger" - LitNumNatural -> panic "GHC.ByteCode.Asm.literal: LitNumNatural" + LitNumBigNat -> panic "GHC.ByteCode.Asm.literal: LitNumBigNat" -- We can lower 'LitRubbish' to an arbitrary constant, but @NULL@ is most -- likely to elicit a crash (rather than corrupt memory) in case absence diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs index d7a78b5888..b43344a92c 100644 --- a/compiler/GHC/Core/Make.hs +++ b/compiler/GHC/Core/Make.hs @@ -304,12 +304,17 @@ mkWordExpr :: Platform -> Integer -> CoreExpr mkWordExpr platform w = mkCoreConApps wordDataCon [mkWordLit platform w] -- | Create a 'CoreExpr' which will evaluate to the given @Integer@ -mkIntegerExpr :: Integer -> CoreExpr -- Result :: Integer -mkIntegerExpr i = Lit (mkLitInteger i) +mkIntegerExpr :: Platform -> Integer -> CoreExpr -- Result :: Integer +mkIntegerExpr platform i + | platformInIntRange platform i = mkCoreConApps integerISDataCon [mkIntLit platform i] + | i < 0 = mkCoreConApps integerINDataCon [Lit (mkLitBigNat (negate i))] + | otherwise = mkCoreConApps integerIPDataCon [Lit (mkLitBigNat i)] -- | Create a 'CoreExpr' which will evaluate to the given @Natural@ -mkNaturalExpr :: Integer -> CoreExpr -mkNaturalExpr i = Lit (mkLitNatural i) +mkNaturalExpr :: Platform -> Integer -> CoreExpr +mkNaturalExpr platform w + | platformInWordRange platform w = mkCoreConApps naturalNSDataCon [mkWordLit platform w] + | otherwise = mkCoreConApps naturalNBDataCon [Lit (mkLitBigNat w)] -- | Create a 'CoreExpr' which will evaluate to the given @Float@ mkFloatExpr :: Float -> CoreExpr diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs index df7e9b0782..35df78e5a7 100644 --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/compiler/GHC/Core/Opt/ConstantFold.hs @@ -47,7 +47,7 @@ import GHC.Types.Basic import GHC.Core import GHC.Core.Make import GHC.Core.SimpleOpt ( exprIsConApp_maybe, exprIsLiteral_maybe ) -import GHC.Core.DataCon ( dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId ) +import GHC.Core.DataCon ( DataCon,dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId ) import GHC.Core.Utils ( eqExpr, cheapEqExpr, exprIsHNF, exprType , stripTicksTop, stripTicksTopT, mkTicks ) import GHC.Core.Multiplicity @@ -1452,30 +1452,52 @@ isLiteral e = do Nothing -> mzero Just l -> pure l +-- | Match Integer and Natural literals +isBignumLiteral :: CoreExpr -> RuleM Integer +isBignumLiteral e = isIntegerLiteral e <|> isNaturalLiteral e + +-- | Match numeric literals isNumberLiteral :: CoreExpr -> RuleM Integer isNumberLiteral e = isLiteral e >>= \case LitNumber _ x -> pure x _ -> mzero +-- | Match the application of a DataCon to a numeric literal. +-- +-- Can be used to match e.g.: +-- IS 123# +-- IP bigNatLiteral +-- W# 123## +isLitNumConApp :: CoreExpr -> RuleM (DataCon,Integer) +isLitNumConApp e = do + env <- getInScopeEnv + case exprIsConApp_maybe env e of + Just (_env,_fb,dc,_tys,[arg]) -> case exprIsLiteral_maybe env arg of + Just (LitNumber _ i) -> pure (dc,i) + _ -> mzero + _ -> mzero + isIntegerLiteral :: CoreExpr -> RuleM Integer -isIntegerLiteral e = isLiteral e >>= \case - LitNumber LitNumInteger x -> pure x - _ -> mzero +isIntegerLiteral e = do + (dc,i) <- isLitNumConApp e + if | dc == integerISDataCon -> pure i + | dc == integerINDataCon -> pure (negate i) + | dc == integerIPDataCon -> pure i + | otherwise -> mzero + +isBigIntegerLiteral :: CoreExpr -> RuleM Integer +isBigIntegerLiteral e = do + (dc,i) <- isLitNumConApp e + if | dc == integerINDataCon -> pure (negate i) + | dc == integerIPDataCon -> pure i + | otherwise -> mzero isNaturalLiteral :: CoreExpr -> RuleM Integer -isNaturalLiteral e = isLiteral e >>= \case - LitNumber LitNumNatural x -> pure x - _ -> mzero - -isWordLiteral :: CoreExpr -> RuleM Integer -isWordLiteral e = isLiteral e >>= \case - LitNumber LitNumWord x -> pure x - _ -> mzero - -isIntLiteral :: CoreExpr -> RuleM Integer -isIntLiteral e = isLiteral e >>= \case - LitNumber LitNumInt x -> pure x - _ -> mzero +isNaturalLiteral e = do + (dc,i) <- isLitNumConApp e + if | dc == naturalNSDataCon -> pure i + | dc == naturalNBDataCon -> pure i + | otherwise -> mzero -- return the n-th argument of this rule, if it is a literal -- argument indices start from 0 @@ -2003,17 +2025,18 @@ builtinBignumRules = y <- isNaturalLiteral a1 -- return an unboxed sum: (# (# #) | Natural #) let ret n v = pure $ mkCoreUbxSum 2 n [unboxedUnitTy,naturalTy] v + platform <- getPlatform if x < y then ret 1 $ Var voidPrimId - else ret 2 $ Lit (mkLitNatural (x - y)) + else ret 2 $ mkNaturalExpr platform (x - y) -- unary operations - , bignum_unop "integerNegate" integerNegateName mkLitInteger negate - , bignum_unop "integerAbs" integerAbsName mkLitInteger abs - , bignum_unop "integerSignum" integerSignumName mkLitInteger signum - , bignum_unop "integerComplement" integerComplementName mkLitInteger complement + , bignum_unop "integerNegate" integerNegateName mkIntegerExpr negate + , bignum_unop "integerAbs" integerAbsName mkIntegerExpr abs + , bignum_unop "integerSignum" integerSignumName mkIntegerExpr signum + , bignum_unop "integerComplement" integerComplementName mkIntegerExpr complement - , bignum_unop "naturalSignum" naturalSignumName mkLitNatural signum + , bignum_unop "naturalSignum" naturalSignumName mkNaturalExpr signum , mkRule "naturalNegate" naturalNegateName 1 $ do [a0] <- getArgs @@ -2033,30 +2056,30 @@ builtinBignumRules = -- -- Bits.bit - , bignum_bit "integerBit" integerBitName mkLitInteger - , bignum_bit "naturalBit" naturalBitName mkLitNatural + , bignum_bit "integerBit" integerBitName mkIntegerExpr + , bignum_bit "naturalBit" naturalBitName mkNaturalExpr -- Bits.testBit , bignum_testbit "integerTestBit" integerTestBitName , bignum_testbit "naturalTestBit" naturalTestBitName -- Bits.shift - , bignum_shift "integerShiftL" integerShiftLName shiftL mkLitInteger - , bignum_shift "integerShiftR" integerShiftRName shiftR mkLitInteger - , bignum_shift "naturalShiftL" naturalShiftLName shiftL mkLitNatural - , bignum_shift "naturalShiftR" naturalShiftRName shiftR mkLitNatural + , bignum_shift "integerShiftL" integerShiftLName shiftL mkIntegerExpr + , bignum_shift "integerShiftR" integerShiftRName shiftR mkIntegerExpr + , bignum_shift "naturalShiftL" naturalShiftLName shiftL mkNaturalExpr + , bignum_shift "naturalShiftR" naturalShiftRName shiftR mkNaturalExpr -- division - , divop_one "integerQuot" integerQuotName quot mkLitInteger - , divop_one "integerRem" integerRemName rem mkLitInteger - , divop_one "integerDiv" integerDivName div mkLitInteger - , divop_one "integerMod" integerModName mod mkLitInteger - , divop_both "integerDivMod" integerDivModName divMod mkLitInteger integerTy - , divop_both "integerQuotRem" integerQuotRemName quotRem mkLitInteger integerTy + , divop_one "integerQuot" integerQuotName quot mkIntegerExpr + , divop_one "integerRem" integerRemName rem mkIntegerExpr + , divop_one "integerDiv" integerDivName div mkIntegerExpr + , divop_one "integerMod" integerModName mod mkIntegerExpr + , divop_both "integerDivMod" integerDivModName divMod mkIntegerExpr integerTy + , divop_both "integerQuotRem" integerQuotRemName quotRem mkIntegerExpr integerTy - , divop_one "naturalQuot" naturalQuotName quot mkLitNatural - , divop_one "naturalRem" naturalRemName rem mkLitNatural - , divop_both "naturalQuotRem" naturalQuotRemName quotRem mkLitNatural naturalTy + , divop_one "naturalQuot" naturalQuotName quot mkNaturalExpr + , divop_one "naturalRem" naturalRemName rem mkNaturalExpr + , divop_both "naturalQuotRem" naturalQuotRemName quotRem mkNaturalExpr naturalTy -- conversions from Rational for Float/Double literals , rational_to "rationalToFloat" rationalToFloatName mkFloatExpr @@ -2080,7 +2103,9 @@ builtinBignumRules = integer_to_lit str name convert = mkRule str name 1 $ do [a0] <- getArgs platform <- getPlatform - x <- isIntegerLiteral a0 + -- we only match on Big Integer literals. Small literals + -- are matched by the "Int# -> Integer -> *" rules + x <- isBigIntegerLiteral a0 pure (convert platform x) natural_to_word str name clamp = mkRule str name 1 $ do @@ -2094,36 +2119,40 @@ builtinBignumRules = integer_to_natural str name thrw clamp = mkRule str name 1 $ do [a0] <- getArgs x <- isIntegerLiteral a0 - if | x >= 0 -> pure $ Lit $ mkLitNatural x + platform <- getPlatform + if | x >= 0 -> pure $ mkNaturalExpr platform x | thrw -> mzero - | clamp -> pure $ Lit $ mkLitNatural 0 -- clamp to 0 - | otherwise -> pure $ Lit $ mkLitNatural (abs x) -- negate/wrap + | clamp -> pure $ mkNaturalExpr platform 0 -- clamp to 0 + | otherwise -> pure $ mkNaturalExpr platform (abs x) -- negate/wrap lit_to_integer str name = mkRule str name 1 $ do [a0] <- getArgs - isLiteral a0 >>= \case - -- convert any numeric literal into an Integer literal - LitNumber _ i -> pure (Lit (mkLitInteger i)) - _ -> mzero + platform <- getPlatform + i <- isNumberLiteral a0 <|> isBignumLiteral a0 + -- convert any numeric literal into an Integer literal + pure (mkIntegerExpr platform i) integer_binop str name op = mkRule str name 2 $ do [a0,a1] <- getArgs x <- isIntegerLiteral a0 y <- isIntegerLiteral a1 - pure (Lit (mkLitInteger (x `op` y))) + platform <- getPlatform + pure (mkIntegerExpr platform (x `op` y)) natural_binop str name op = mkRule str name 2 $ do [a0,a1] <- getArgs x <- isNaturalLiteral a0 y <- isNaturalLiteral a1 - pure (Lit (mkLitNatural (x `op` y))) + platform <- getPlatform + pure (mkNaturalExpr platform (x `op` y)) natural_sub str name = mkRule str name 2 $ do [a0,a1] <- getArgs x <- isNaturalLiteral a0 y <- isNaturalLiteral a1 guard (x >= y) - pure (Lit (mkLitNatural (x - y))) + platform <- getPlatform + pure (mkNaturalExpr platform (x - y)) integer_cmp str name op = mkRule str name 2 $ do platform <- getPlatform @@ -2145,8 +2174,8 @@ builtinBignumRules = bignum_compare str name = mkRule str name 2 $ do [a0,a1] <- getArgs - x <- isNumberLiteral a0 - y <- isNumberLiteral a1 + x <- isBignumLiteral a0 + y <- isBignumLiteral a1 pure $ case x `compare` y of LT -> ltVal EQ -> eqVal @@ -2154,8 +2183,9 @@ builtinBignumRules = bignum_unop str name mk_lit op = mkRule str name 1 $ do [a0] <- getArgs - x <- isNumberLiteral a0 - pure $ Lit (mk_lit (op x)) + x <- isBignumLiteral a0 + platform <- getPlatform + pure $ mk_lit platform (op x) bignum_popcount str name mk_lit = mkRule str name 1 $ do platform <- getPlatform @@ -2164,7 +2194,7 @@ builtinBignumRules = -- by the target. So we disable this rule if sizes don't match. guard (platformWordSizeInBits platform == finiteBitSize (0 :: Word)) [a0] <- getArgs - x <- isNumberLiteral a0 + x <- isBignumLiteral a0 pure $ Lit (mk_lit platform (fromIntegral (popCount x))) bignum_bit str name mk_lit = mkRule str name 1 $ do @@ -2178,12 +2208,12 @@ builtinBignumRules = guard (n >= 0 && n <= fromIntegral (platformWordSizeInBits platform)) -- it's safe to convert a target Int value into a host Int value -- to perform the "bit" operation because n is very small (<= 64). - pure $ Lit (mk_lit (bit (fromIntegral n))) + pure $ mk_lit platform (bit (fromIntegral n)) bignum_testbit str name = mkRule str name 2 $ do [a0,a1] <- getArgs platform <- getPlatform - x <- isNumberLiteral a0 + x <- isBignumLiteral a0 n <- isNumberLiteral a1 -- ensure that we can store 'n' in a host Int guard (n >= 0 && n <= fromIntegral (maxBound :: Int)) @@ -2193,34 +2223,37 @@ builtinBignumRules = bignum_shift str name shift_op mk_lit = mkRule str name 2 $ do [a0,a1] <- getArgs - x <- isNumberLiteral a0 - n <- isWordLiteral a1 + x <- isBignumLiteral a0 + n <- isNumberLiteral a1 -- See Note [Guarding against silly shifts] -- Restrict constant-folding of shifts on Integers, somewhat arbitrary. -- We can get huge shifts in inaccessible code (#15673) guard (n <= 4) - pure $ Lit (mk_lit (x `shift_op` fromIntegral n)) + platform <- getPlatform + pure $ mk_lit platform (x `shift_op` fromIntegral n) divop_one str name divop mk_lit = mkRule str name 2 $ do [a0,a1] <- getArgs - n <- isNumberLiteral a0 - d <- isNumberLiteral a1 + n <- isBignumLiteral a0 + d <- isBignumLiteral a1 guard (d /= 0) - pure $ Lit (mk_lit (n `divop` d)) + platform <- getPlatform + pure $ mk_lit platform (n `divop` d) divop_both str name divop mk_lit ty = mkRule str name 2 $ do [a0,a1] <- getArgs - n <- isNumberLiteral a0 - d <- isNumberLiteral a1 + n <- isBignumLiteral a0 + d <- isBignumLiteral a1 guard (d /= 0) let (r,s) = n `divop` d - pure $ mkCoreUbxTup [ty,ty] [Lit (mk_lit r), Lit (mk_lit s)] + platform <- getPlatform + pure $ mkCoreUbxTup [ty,ty] [mk_lit platform r, mk_lit platform s] integer_encode_float :: RealFloat a => String -> Name -> (a -> CoreExpr) -> CoreRule integer_encode_float str name mk_lit = mkRule str name 2 $ do [a0,a1] <- getArgs x <- isIntegerLiteral a0 - y <- isIntLiteral a1 + y <- isNumberLiteral a1 -- check that y (a target Int) is in the host Int range guard (y <= fromIntegral (maxBound :: Int)) pure (mk_lit $ encodeFloat x (fromInteger y)) diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index d741aa0351..720bc895c8 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -4,8 +4,6 @@ -} -{-# LANGUAGE MultiWayIf #-} - module GHC.Core.SimpleOpt ( SimpleOpts (..), defaultSimpleOpts, @@ -1284,36 +1282,15 @@ than the ordinary arity of the dfun: see Note [DFun unfoldings] in GHC.Core exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal -- Same deal as exprIsConApp_maybe, but much simpler -- Nevertheless we do need to look through unfoldings for --- Integer and string literals, which are vigorously hoisted to top level +-- string literals, which are vigorously hoisted to top level -- and not subsequently inlined exprIsLiteral_maybe env@(_, id_unf) e = case e of Lit l -> Just l Tick _ e' -> exprIsLiteral_maybe env e' -- dubious? - Var v - | Just rhs <- expandUnfolding_maybe (id_unf v) - , Just l <- exprIsLiteral_maybe env rhs - -> Just l - Var v - | Just rhs <- expandUnfolding_maybe (id_unf v) - , Just b <- matchBignum env rhs - -> Just b - e - | Just b <- matchBignum env e - -> Just b - - | otherwise - -> Nothing - where - matchBignum env e - | Just (_env,_fb,dc,_tys,[arg]) <- exprIsConApp_maybe env e - , Just (LitNumber _ i) <- exprIsLiteral_maybe env arg - = if - | dc == naturalNSDataCon -> Just (mkLitNatural i) - | dc == integerISDataCon -> Just (mkLitInteger i) - | otherwise -> Nothing - | otherwise - = Nothing + Var v -> expandUnfolding_maybe (id_unf v) + >>= exprIsLiteral_maybe env + _ -> Nothing {- Note [exprIsLambda_maybe] diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs index f8dadf8c16..dbc6b1e7fd 100644 --- a/compiler/GHC/Core/Unfold.hs +++ b/compiler/GHC/Core/Unfold.hs @@ -621,8 +621,7 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr -- | Finds a nominal size of a string literal. litSize :: Literal -> Int -- Used by GHC.Core.Unfold.sizeExpr -litSize (LitNumber LitNumInteger _) = 100 -- Note [Size of literal integers] -litSize (LitNumber LitNumNatural _) = 100 +litSize (LitNumber LitNumBigNat _) = 100 litSize (LitString str) = 10 + 10 * ((BS.length str + 3) `div` 4) -- If size could be 0 then @f "x"@ might be too small -- [Sept03: make literal strings a bit bigger to avoid fruitless diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs index a258a424dc..8d99965513 100644 --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -386,10 +386,9 @@ coreToStgExpr -- on these components, but it in turn is not scrutinised as the basis for any -- decisions. Hence no black holes. --- No LitInteger's or LitNatural's should be left by the time this is called. +-- No bignum literal should be left by the time this is called. -- CorePrep should have converted them all to a real core representation. -coreToStgExpr (Lit (LitNumber LitNumInteger _)) = panic "coreToStgExpr: LitInteger" -coreToStgExpr (Lit (LitNumber LitNumNatural _)) = panic "coreToStgExpr: LitNatural" +coreToStgExpr (Lit (LitNumber LitNumBigNat _)) = panic "coreToStgExpr: LitNumBigNat" coreToStgExpr (Lit l) = return (StgLit l) coreToStgExpr (Var v) = coreToStgApp v [] [] coreToStgExpr (Coercion _) diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index 30c28a6db2..675ef7776c 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -131,8 +131,7 @@ The goal of this pass is to prepare for code generation. 9. Replace (lazy e) by e. See Note [lazyId magic] in GHC.Types.Id.Make Also replace (noinline e) by e. -10. Convert bignum literals (LitNatural and LitInteger) into their - core representation. +10. Convert bignum literals into their core representation. 11. Uphold tick consistency while doing this: We move ticks out of (non-type) applications where we can, and make sure that we @@ -2146,37 +2145,9 @@ mkConvertNumLiteral hsc_env = do let convertNumLit nt i = case nt of - LitNumInteger -> Just (convertInteger i) - LitNumNatural -> Just (convertNatural i) + LitNumBigNat -> Just (convertBignatPrim i) _ -> Nothing - convertInteger i - | platformInIntRange platform i -- fit in a Int# - = mkConApp integerISDataCon [Lit (mkLitInt platform i)] - - | otherwise -- build a BigNat and embed into IN or IP - = let con = if i > 0 then integerIPDataCon else integerINDataCon - in mkBigNum con (convertBignatPrim (abs i)) - - convertNatural i - | platformInWordRange platform i -- fit in a Word# - = mkConApp naturalNSDataCon [Lit (mkLitWord platform i)] - - | otherwise --build a BigNat and embed into NB - = mkBigNum naturalNBDataCon (convertBignatPrim i) - - -- we can't simply generate: - -- - -- NB (bigNatFromWordList# [W# 10, W# 20]) - -- - -- using `mkConApp` because it isn't in ANF form. Instead we generate: - -- - -- case bigNatFromWordList# [W# 10, W# 20] of ba { DEFAULT -> NB ba } - -- - -- via `mkCoreApps` - - mkBigNum con ba = mkCoreApps (Var (dataConWorkId con)) [ba] - convertBignatPrim i = let target = targetPlatform dflags 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) diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs index 1ba0687a9b..e056dadc2b 100644 --- a/compiler/GHC/StgToByteCode.hs +++ b/compiler/GHC/StgToByteCode.hs @@ -1716,11 +1716,9 @@ pushLiteral padded lit = LitNumWord32 -> code Word32Rep LitNumInt64 -> code Int64Rep LitNumWord64 -> code Word64Rep - -- No LitInteger's or LitNatural's should be left by the time this is - -- called. CorePrep should have converted them all to a real core - -- representation. - LitNumInteger -> panic "pushAtom: LitInteger" - LitNumNatural -> panic "pushAtom: LitNatural" + -- No LitNumBigNat should be left by the time this is called. CorePrep + -- should have converted them all to a real core representation. + LitNumBigNat -> panic "pushAtom: LitNumBigNat" -- | Push an atom for constructor (i.e., PACK instruction) onto the stack. -- This is slightly different to @pushAtom@ due to the fact that we allow diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs index f80d3eaf93..757226ed28 100644 --- a/compiler/GHC/Tc/Instance/Class.hs +++ b/compiler/GHC/Tc/Instance/Class.hs @@ -359,8 +359,8 @@ matchKnownNat :: DynFlags -> Bool -- True <=> caller is the short-cut solver -- See Note [Shortcut solving: overlap] -> Class -> [Type] -> TcM ClsInstResult -matchKnownNat _ _ clas [ty] -- clas = KnownNat - | Just n <- isNumLitTy ty = makeLitDict clas ty (mkNaturalExpr n) +matchKnownNat dflags _ clas [ty] -- clas = KnownNat + | Just n <- isNumLitTy ty = makeLitDict clas ty (mkNaturalExpr (targetPlatform dflags) n) matchKnownNat df sc clas tys = matchInstEnv df sc clas tys -- See Note [Fabricating Evidence for Literals in Backpack] for why -- this lookup into the instance environment is required. diff --git a/compiler/GHC/Tc/Plugin.hs b/compiler/GHC/Tc/Plugin.hs index a62ac86734..f65b30db27 100644 --- a/compiler/GHC/Tc/Plugin.hs +++ b/compiler/GHC/Tc/Plugin.hs @@ -24,6 +24,7 @@ module GHC.Tc.Plugin ( -- * Getting the TcM state getTopEnv, + getTargetPlatform, getEnvs, getInstEnvs, getFamInstEnvs, @@ -51,6 +52,8 @@ module GHC.Tc.Plugin ( import GHC.Prelude +import GHC.Platform (Platform) + import qualified GHC.Tc.Utils.Monad as TcM import qualified GHC.Tc.Solver.Monad as TcS import qualified GHC.Tc.Utils.Env as TcM @@ -132,6 +135,10 @@ tcLookupId = unsafeTcPluginTcM . TcM.tcLookupId getTopEnv :: TcPluginM HscEnv getTopEnv = unsafeTcPluginTcM TcM.getTopEnv +getTargetPlatform :: TcPluginM Platform +getTargetPlatform = unsafeTcPluginTcM TcM.getPlatform + + getEnvs :: TcPluginM (TcGblEnv, TcLclEnv) getEnvs = unsafeTcPluginTcM TcM.getEnvs diff --git a/compiler/GHC/Types/Literal.hs b/compiler/GHC/Types/Literal.hs index 968e26c03b..4b6775cc58 100644 --- a/compiler/GHC/Types/Literal.hs +++ b/compiler/GHC/Types/Literal.hs @@ -31,7 +31,7 @@ module GHC.Types.Literal , mkLitWord64, mkLitWord64Wrap, mkLitWord64Unchecked , mkLitFloat, mkLitDouble , mkLitChar, mkLitString - , mkLitInteger, mkLitNatural + , mkLitBigNat , mkLitNumber, mkLitNumberWrap -- ** Operations on Literals @@ -67,7 +67,6 @@ module GHC.Types.Literal import GHC.Prelude import GHC.Builtin.Types.Prim -import {-# SOURCE #-} GHC.Builtin.Types import GHC.Core.Type import GHC.Utils.Outputable import GHC.Data.FastString @@ -162,8 +161,7 @@ data Literal -- | Numeric literal type data LitNumType - = LitNumInteger -- ^ @Integer@ (see Note [BigNum literals]) - | LitNumNatural -- ^ @Natural@ (see Note [BigNum literals]) + = LitNumBigNat -- ^ @Bignat@ (see Note [BigNum literals]) | LitNumInt -- ^ @Int#@ - according to target machine | LitNumInt8 -- ^ @Int8#@ - exactly 8 bits | LitNumInt16 -- ^ @Int16#@ - exactly 16 bits @@ -179,8 +177,7 @@ data LitNumType -- | Indicate if a numeric literal type supports negative numbers litNumIsSigned :: LitNumType -> Bool litNumIsSigned nt = case nt of - LitNumInteger -> True - LitNumNatural -> False + LitNumBigNat -> False LitNumInt -> True LitNumInt8 -> True LitNumInt16 -> True @@ -195,8 +192,7 @@ litNumIsSigned nt = case nt of -- | Number of bits litNumBitSize :: Platform -> LitNumType -> Maybe Word litNumBitSize platform nt = case nt of - LitNumInteger -> Nothing - LitNumNatural -> Nothing + LitNumBigNat -> Nothing LitNumInt -> Just (fromIntegral (platformWordSizeInBits platform)) LitNumInt8 -> Just 8 LitNumInt16 -> Just 16 @@ -217,16 +213,28 @@ instance Binary LitNumType where {- Note [BigNum literals] ~~~~~~~~~~~~~~~~~~~~~~ -GHC supports 2 kinds of arbitrary precision integers (a.k.a BigNum): +GHC supports 2 kinds of arbitrary precision numbers (a.k.a BigNum): - * Natural: natural represented as a Word# or as a BigNat + * data Natural = NS Word# | NB BigNat# - * Integer: integer represented a an Int# or as a BigNat (Integer's - constructors indicate the sign) + * data Integer = IS Int# | IN BigNat# | IP BigNat# -BigNum literal instances are removed from Core during the CorePrep phase. They -are replaced with expression to build them at runtime from machine literals -(Word#, Int#, etc.) or from a list of Word#s. +In the past, we had Core constructors to represent Integer and Natural literals. +These literals were then lowered into their real Core representation only in +Core prep. The issue with this approach is that literals have two +representations and we have to ensure that we handle them the same everywhere +(in every optimisation, etc.). + +For example (0 :: Integer) was representable in Core with both: + + Lit (LitNumber LitNumInteger 0) -- literal + App (Var integerISDataCon) (Lit (LitNumber LitNumInt 0)) -- real representation + +Nowadays we always use the real representation for Integer and Natural literals. +However we still have two representations for BigNat# literals. BigNat# literals +are still lowered in Core prep into a call to a constructor function (BigNat# is +ByteArray# and we don't have ByteArray# literals yet so we have to build them at +runtime). Note [String literals] ~~~~~~~~~~~~~~~~~~~~~~ @@ -340,9 +348,8 @@ mkLitNumberWrap platform nt i = case nt of LitNumWord16 -> wrap @Word16 LitNumWord32 -> wrap @Word32 LitNumWord64 -> wrap @Word64 - LitNumInteger -> LitNumber nt i - LitNumNatural - | i < 0 -> panic "mkLitNumberWrap: trying to create a negative Natural" + LitNumBigNat + | i < 0 -> panic "mkLitNumberWrap: trying to create a negative BigNat" | otherwise -> LitNumber nt i where wrap :: forall a. (Integral a, Num a) => Literal @@ -389,8 +396,7 @@ litNumRange platform nt = case nt of LitNumWord16 -> bounded_range @Word16 LitNumWord32 -> bounded_range @Word32 LitNumWord64 -> bounded_range @Word64 - LitNumNatural -> (Just 0, Nothing) - LitNumInteger -> (Nothing, Nothing) + LitNumBigNat -> (Just 0, Nothing) where bounded_range :: forall a . (Integral a, Bounded a) => (Maybe Integer,Maybe Integer) bounded_range = case boundedRange @a of @@ -572,20 +578,14 @@ mkLitString :: String -> Literal -- stored UTF-8 encoded mkLitString s = LitString (bytesFS $ mkFastString s) -mkLitInteger :: Integer -> Literal -mkLitInteger x = LitNumber LitNumInteger x - -mkLitNatural :: Integer -> Literal -mkLitNatural x = assertPpr (inNaturalRange x) (integer x) - (LitNumber LitNumNatural x) +mkLitBigNat :: Integer -> Literal +mkLitBigNat x = assertPpr (x >= 0) (integer x) + (LitNumber LitNumBigNat x) isLitRubbish :: Literal -> Bool isLitRubbish (LitRubbish {}) = True isLitRubbish _ = False -inNaturalRange :: Integer -> Bool -inNaturalRange x = x >= 0 - inBoundedRange :: forall a. (Bounded a, Integral a) => Integer -> Bool inBoundedRange x = x >= toInteger (minBound :: a) && x <= toInteger (maxBound :: a) @@ -606,8 +606,7 @@ isMinBound platform (LitNumber nt i) = case nt of LitNumWord16 -> i == 0 LitNumWord32 -> i == 0 LitNumWord64 -> i == 0 - LitNumNatural -> i == 0 - LitNumInteger -> False + LitNumBigNat -> i == 0 isMinBound _ _ = False isMaxBound :: Platform -> Literal -> Bool @@ -623,8 +622,7 @@ isMaxBound platform (LitNumber nt i) = case nt of LitNumWord16 -> i == toInteger (maxBound :: Word16) LitNumWord32 -> i == toInteger (maxBound :: Word32) LitNumWord64 -> i == toInteger (maxBound :: Word64) - LitNumNatural -> False - LitNumInteger -> False + LitNumBigNat -> False isMaxBound _ _ = False inCharRange :: Char -> Bool @@ -645,7 +643,7 @@ isOneLit (LitDouble 1) = True isOneLit _ = False -- | Returns the 'Integer' contained in the 'Literal', for when that makes --- sense, i.e. for 'Char', 'Int', 'Word', 'LitInteger' and 'LitNatural'. +-- sense, i.e. for 'Char' and numbers. litValue :: Literal -> Integer litValue l = case isLitValue_maybe l of Just x -> x @@ -769,8 +767,7 @@ litIsTrivial :: Literal -> Bool -- c.f. GHC.Core.Utils.exprIsTrivial litIsTrivial (LitString _) = False litIsTrivial (LitNumber nt _) = case nt of - LitNumInteger -> False - LitNumNatural -> False + LitNumBigNat -> False LitNumInt -> True LitNumInt8 -> True LitNumInt16 -> True @@ -787,9 +784,8 @@ litIsTrivial _ = True litIsDupable :: Platform -> Literal -> Bool -- c.f. GHC.Core.Utils.exprIsDupable litIsDupable platform x = case x of - (LitNumber nt i) -> case nt of - LitNumInteger -> platformInIntRange platform i - LitNumNatural -> platformInWordRange platform i + LitNumber nt i -> case nt of + LitNumBigNat -> i <= platformMaxWord platform * 8 -- arbitrary, reasonable LitNumInt -> True LitNumInt8 -> True LitNumInt16 -> True @@ -800,8 +796,8 @@ litIsDupable platform x = case x of LitNumWord16 -> True LitNumWord32 -> True LitNumWord64 -> True - (LitString _) -> False - _ -> True + LitString _ -> False + _ -> True litFitsInChar :: Literal -> Bool litFitsInChar (LitNumber _ i) = i >= toInteger (ord minBound) @@ -810,8 +806,7 @@ litFitsInChar _ = False litIsLifted :: Literal -> Bool litIsLifted (LitNumber nt _) = case nt of - LitNumInteger -> True - LitNumNatural -> True + LitNumBigNat -> True LitNumInt -> False LitNumInt8 -> False LitNumInt16 -> False @@ -839,8 +834,7 @@ literalType (LitFloat _) = floatPrimTy literalType (LitDouble _) = doublePrimTy literalType (LitLabel _ _ _) = addrPrimTy literalType (LitNumber lt _) = case lt of - LitNumInteger -> integerTy - LitNumNatural -> naturalTy + LitNumBigNat -> byteArrayPrimTy LitNumInt -> intPrimTy LitNumInt8 -> int8PrimTy LitNumInt16 -> int16PrimTy @@ -889,10 +883,9 @@ pprLiteral _ (LitString s) = pprHsBytes s pprLiteral _ (LitNullAddr) = text "__NULL" pprLiteral _ (LitFloat f) = float (fromRat f) <> primFloatSuffix pprLiteral _ (LitDouble d) = double (fromRat d) <> primDoubleSuffix -pprLiteral add_par (LitNumber nt i) +pprLiteral _ (LitNumber nt i) = case nt of - LitNumInteger -> pprIntegerVal add_par i - LitNumNatural -> pprIntegerVal add_par i + LitNumBigNat -> integer i LitNumInt -> pprPrimInt i LitNumInt8 -> pprPrimInt8 i LitNumInt16 -> pprPrimInt16 i @@ -911,17 +904,12 @@ pprLiteral add_par (LitLabel l mb fod) = pprLiteral _ (LitRubbish rep) = text "RUBBISH" <> parens (ppr rep) -pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc --- See Note [Printing of literals in Core]. -pprIntegerVal add_par i | i < 0 = add_par (integer i) - | otherwise = integer i - {- Note [Printing of literals in Core] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The function `add_par` is used to wrap parenthesis around negative integers -(`LitInteger`) and labels (`LitLabel`), if they occur in a context requiring -an atomic thing (for example function application). +The function `add_par` is used to wrap parenthesis around labels (`LitLabel`), +if they occur in a context requiring an atomic thing (for example function +application). Although not all Core literals would be valid Haskell, we are trying to stay as close as possible to Haskell syntax in the printing of Core, to make it @@ -949,7 +937,7 @@ LitWord 1## LitWordN 1##N LitFloat -1.0# LitDouble -1.0## -LitInteger -1 (-1) +LitBigNat 1 LitLabel "__label" ... ("__label" ...) LitRubbish "RUBBISH[...]" diff --git a/testsuite/tests/lib/integer/all.T b/testsuite/tests/lib/integer/all.T index 4366955e81..96cb055b9c 100644 --- a/testsuite/tests/lib/integer/all.T +++ b/testsuite/tests/lib/integer/all.T @@ -5,12 +5,7 @@ test('plusMinusInteger', [omit_ways(['ghci'])], compile_and_run, ['']) test('integerConstantFolding', normal, makefile_test, ['integerConstantFolding']) test('naturalConstantFolding', normal, makefile_test, ['naturalConstantFolding']) -# we ignore_stderr because there are 2 overlapping rules that are reported in -# debug mode: -# Rules.findBest: rule overlap (Rule 1 wins) -# Rule 1: "Integer -> Int# (wrap)" -# Rule 2: "Int# -> Integer -> Int#" -test('fromToInteger', [ignore_stderr], makefile_test, ['fromToInteger']) +test('fromToInteger', normal, makefile_test, ['fromToInteger']) test('IntegerConversionRules', [], makefile_test, ['IntegerConversionRules']) test('gcdInteger', normal, compile_and_run, ['']) diff --git a/testsuite/tests/numeric/should_compile/T14170.stdout b/testsuite/tests/numeric/should_compile/T14170.stdout index a4fe7ecd7b..89e0f1b461 100644 --- a/testsuite/tests/numeric/should_compile/T14170.stdout +++ b/testsuite/tests/numeric/should_compile/T14170.stdout @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 16, types: 6, coercions: 0, joins: 0/0} + = {terms: 17, types: 6, coercions: 0, joins: 0/0} NatVal.$trModule4 :: GHC.Prim.Addr# [GblId, @@ -37,8 +37,8 @@ NatVal.$trModule foo :: Integer [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 100 0}] -foo = 0 + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +foo = GHC.Num.Integer.IS 0# diff --git a/testsuite/tests/numeric/should_compile/T14465.stdout b/testsuite/tests/numeric/should_compile/T14465.stdout index 808b75f633..de0c34607d 100644 --- a/testsuite/tests/numeric/should_compile/T14465.stdout +++ b/testsuite/tests/numeric/should_compile/T14465.stdout @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 35, types: 14, coercions: 0, joins: 0/0} + = {terms: 37, types: 14, coercions: 0, joins: 0/0} ten :: Natural [GblId, @@ -42,8 +42,8 @@ M.$trModule = GHC.Types.Module M.$trModule3 M.$trModule1 M.minusOne1 :: Natural [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 100 0}] -M.minusOne1 = 1 + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +M.minusOne1 = GHC.Num.Natural.NS 1## minusOne :: Natural [GblId, @@ -58,8 +58,8 @@ minusOne twoTimesTwo :: Natural [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 100 0}] -twoTimesTwo = 4 + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +twoTimesTwo = GHC.Num.Natural.NS 4## plusOne :: Natural -> Natural [GblId, diff --git a/testsuite/tests/numeric/should_compile/T20245.hs b/testsuite/tests/numeric/should_compile/T20245.hs new file mode 100644 index 0000000000..1196987cf9 --- /dev/null +++ b/testsuite/tests/numeric/should_compile/T20245.hs @@ -0,0 +1,9 @@ +module T20245 where + +import GHC.Num.Integer + +foo :: Int +foo = case 2 of + IS _ -> 9999 + IP _ -> 7777 + IN _ -> 7777 diff --git a/testsuite/tests/numeric/should_compile/T20245.stderr b/testsuite/tests/numeric/should_compile/T20245.stderr new file mode 100644 index 0000000000..e3fe0ed315 --- /dev/null +++ b/testsuite/tests/numeric/should_compile/T20245.stderr @@ -0,0 +1,9 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 3, types: 1, coercions: 0, joins: 0/0} + +foo = I# 9999# + + + diff --git a/testsuite/tests/numeric/should_compile/all.T b/testsuite/tests/numeric/should_compile/all.T index 425d0dbd85..c95296fcde 100644 --- a/testsuite/tests/numeric/should_compile/all.T +++ b/testsuite/tests/numeric/should_compile/all.T @@ -11,3 +11,4 @@ test('T10929', normal, compile, ['']) test('T16402', [ grep_errmsg(r'and'), when(wordsize(32), expect_broken(19024)) ], compile, ['']) test('T19892', normal, compile, ['-O -ddump-rule-firings']) test('T20062', [ grep_errmsg(r'integer') ], compile, ['-ddump-simpl -O -dsuppress-all']) +test('T20245', normal, compile, ['-ddump-simpl -O -dsuppress-all -dno-typeable-binds']) diff --git a/testsuite/tests/simplCore/should_compile/T15445.stderr b/testsuite/tests/simplCore/should_compile/T15445.stderr index 3421b37072..5e8a086e6d 100644 --- a/testsuite/tests/simplCore/should_compile/T15445.stderr +++ b/testsuite/tests/simplCore/should_compile/T15445.stderr @@ -1,6 +1,6 @@ Rule fired: Class op + (BUILTIN) Rule fired: Class op fromInteger (BUILTIN) -Rule fired: Integer -> Int# (wrap) (BUILTIN) +Rule fired: Int# -> Integer -> Int# (GHC.Num.Integer) Rule fired: SPEC plusTwoRec (T15445a) Rule fired: SPEC $fShow[] (GHC.Show) Rule fired: Class op >> (BUILTIN) diff --git a/testsuite/tests/simplCore/should_compile/T8832.stdout-ws-32 b/testsuite/tests/simplCore/should_compile/T8832.stdout-ws-32 index 459d2689c7..53b2c046c1 100644 --- a/testsuite/tests/simplCore/should_compile/T8832.stdout-ws-32 +++ b/testsuite/tests/simplCore/should_compile/T8832.stdout-ws-32 @@ -6,4 +6,4 @@ w = GHC.Types.W# 0## w8 = GHC.Word.W8# 0##8 w16 = GHC.Word.W16# 0##16 w32 = GHC.Word.W32# 0##32 -z = 0 +z = GHC.Num.Integer.IS 0# diff --git a/testsuite/tests/simplCore/should_compile/T8832.stdout-ws-64 b/testsuite/tests/simplCore/should_compile/T8832.stdout-ws-64 index 657f517c68..625102854d 100644 --- a/testsuite/tests/simplCore/should_compile/T8832.stdout-ws-64 +++ b/testsuite/tests/simplCore/should_compile/T8832.stdout-ws-64 @@ -8,4 +8,4 @@ w8 = GHC.Word.W8# 0##8 w16 = GHC.Word.W16# 0##16 w32 = GHC.Word.W32# 0##32 w64 = GHC.Word.W64# 0## -z = 0 +z = GHC.Num.Integer.IS 0# diff --git a/testsuite/tests/tcplugins/ArgsPlugin.hs b/testsuite/tests/tcplugins/ArgsPlugin.hs index c25c8dc8a3..19e99bedd0 100644 --- a/testsuite/tests/tcplugins/ArgsPlugin.hs +++ b/testsuite/tests/tcplugins/ArgsPlugin.hs @@ -22,13 +22,15 @@ import GHC.Core.Type import GHC.Plugins ( Plugin ) import GHC.Tc.Plugin - ( TcPluginM ) + ( TcPluginM, getTargetPlatform ) import GHC.Tc.Types ( TcPluginSolveResult(..) ) import GHC.Tc.Types.Constraint ( Ct(..) ) import GHC.Tc.Types.Evidence ( EvBindsVar, EvTerm(EvExpr) ) +import GHC.Platform + ( Platform ) -- common import Common @@ -62,11 +64,12 @@ solver args defs _ev _gs _ds ws = do argsVal = case args of arg : _ -> read arg _ -> error "ArgsPlugin: expected at least one argument" - solved <- catMaybes <$> traverse ( solveCt defs argsVal ) ws + platform <- getTargetPlatform + solved <- catMaybes <$> traverse ( solveCt platform defs argsVal ) ws pure $ TcPluginOk solved [] -solveCt :: PluginDefs -> Integer -> Ct -> TcPluginM ( Maybe (EvTerm, Ct) ) -solveCt ( PluginDefs {..} ) i ct@( CDictCan { cc_class, cc_tyargs } ) +solveCt :: Platform -> PluginDefs -> Integer -> Ct -> TcPluginM ( Maybe (EvTerm, Ct) ) +solveCt platform ( PluginDefs {..} ) i ct@( CDictCan { cc_class, cc_tyargs } ) | className cc_class == className myClass , [tyArg] <- cc_tyargs , tyArg `eqType` integerTy @@ -74,6 +77,6 @@ solveCt ( PluginDefs {..} ) i ct@( CDictCan { cc_class, cc_tyargs } ) evTerm :: EvTerm evTerm = EvExpr $ mkCoreConApps ( classDataCon cc_class ) - [ Type integerTy, mkIntegerExpr i ] + [ Type integerTy, mkIntegerExpr platform i ] = pure $ Just ( evTerm, ct ) -solveCt _ _ ct = pure Nothing +solveCt _ _ _ ct = pure Nothing |