diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2021-01-15 12:33:40 +0100 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-01-23 15:31:20 -0500 |
| commit | 773e2828fde4d8f640082b6bded9945e7b9584e3 (patch) | |
| tree | 735cc36bc1ce14820890f8734e68280521a6e2ce | |
| parent | 97208613414106e493a586d295ca05393e136ba4 (diff) | |
| download | haskell-773e2828fde4d8f640082b6bded9945e7b9584e3.tar.gz | |
Bignum: add Natural constant folding rules (#15821)
* Implement constant folding rules for Natural (similar to Integer ones)
* Add mkCoreUbxSum helper in GHC.Core.Make
* Remove naturalTo/FromInt
We now only provide `naturalTo/FromWord` as
the semantics is clear (truncate/zero-extend). For Int we have to deal
with negative numbers (throw an exception? convert to Word
beforehand?) so we leave the decision about what to do to the caller.
Moreover, now that we have sized types (Int8#, Int16#, ..., Word8#,
etc.) there is no reason to bless `Int#` more than `Int8#` or `Word8#`
(for example).
* Replaced a few `()` with `(# #)`
22 files changed, 1056 insertions, 523 deletions
diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs index f2b794eebd..e04c2e81b7 100644 --- a/compiler/GHC/Builtin/Names.hs +++ b/compiler/GHC/Builtin/Names.hs @@ -350,6 +350,7 @@ basicKnownKeyNames integerFromNaturalName, integerToNaturalClampName, integerToNaturalThrowName, + integerToNaturalName, integerToWordName, integerToIntName, integerToWord64Name, @@ -361,15 +362,16 @@ basicKnownKeyNames integerMulName, integerSubName, integerNegateName, - integerEqPrimName, - integerNePrimName, - integerLePrimName, - integerGtPrimName, - integerLtPrimName, - integerGePrimName, + integerEqName, + integerNeName, + integerLeName, + integerGtName, + integerLtName, + integerGeName, integerAbsName, integerSignumName, integerCompareName, + integerPopCountName, integerQuotName, integerRemName, integerDivName, @@ -387,16 +389,48 @@ basicKnownKeyNames integerXorName, integerComplementName, integerBitName, + integerTestBitName, integerShiftLName, integerShiftRName, + naturalToWordName, + naturalToWordClampName, + naturalEqName, + naturalNeName, + naturalGeName, + naturalLeName, + naturalGtName, + naturalLtName, + naturalCompareName, + naturalPopCountName, + naturalShiftRName, + naturalShiftLName, naturalAddName, naturalSubName, + naturalSubThrowName, + naturalSubUnsafeName, naturalMulName, + naturalSignumName, + naturalNegateName, + naturalQuotRemName, naturalQuotName, naturalRemName, - naturalQuotRemName, + naturalAndName, + naturalAndNotName, + naturalOrName, + naturalXorName, + naturalTestBitName, + naturalBitName, + naturalGcdName, + naturalLcmName, + naturalLog2Name, + naturalLogBaseWordName, + naturalLogBaseName, + naturalPowModName, + naturalSizeInBaseName, + bignatFromWordListName, + -- Float/Double rationalToFloatName, rationalToDoubleName, @@ -1125,6 +1159,7 @@ negateName = varQual gHC_NUM (fsLit "negate") negateClassOpKey integerFromNaturalName , integerToNaturalClampName , integerToNaturalThrowName + , integerToNaturalName , integerToWordName , integerToIntName , integerToWord64Name @@ -1136,15 +1171,16 @@ integerFromNaturalName , integerMulName , integerSubName , integerNegateName - , integerEqPrimName - , integerNePrimName - , integerLePrimName - , integerGtPrimName - , integerLtPrimName - , integerGePrimName + , integerEqName + , integerNeName + , integerLeName + , integerGtName + , integerLtName + , integerGeName , integerAbsName , integerSignumName , integerCompareName + , integerPopCountName , integerQuotName , integerRemName , integerDivName @@ -1162,15 +1198,44 @@ integerFromNaturalName , integerXorName , integerComplementName , integerBitName + , integerTestBitName , integerShiftLName , integerShiftRName , naturalToWordName + , naturalToWordClampName + , naturalEqName + , naturalNeName + , naturalGeName + , naturalLeName + , naturalGtName + , naturalLtName + , naturalCompareName + , naturalPopCountName + , naturalShiftRName + , naturalShiftLName , naturalAddName , naturalSubName + , naturalSubThrowName + , naturalSubUnsafeName , naturalMulName + , naturalSignumName + , naturalNegateName + , naturalQuotRemName , naturalQuotName , naturalRemName - , naturalQuotRemName + , naturalAndName + , naturalAndNotName + , naturalOrName + , naturalXorName + , naturalTestBitName + , naturalBitName + , naturalGcdName + , naturalLcmName + , naturalLog2Name + , naturalLogBaseWordName + , naturalLogBaseName + , naturalPowModName + , naturalSizeInBaseName , bignatFromWordListName :: Name @@ -1183,16 +1248,45 @@ bniVarQual str key = varQual gHC_NUM_INTEGER (fsLit str) key bignatFromWordListName = bnbVarQual "bigNatFromWordList#" bignatFromWordListIdKey naturalToWordName = bnnVarQual "naturalToWord#" naturalToWordIdKey +naturalToWordClampName = bnnVarQual "naturalToWordClamp#" naturalToWordClampIdKey +naturalEqName = bnnVarQual "naturalEq#" naturalEqIdKey +naturalNeName = bnnVarQual "naturalNe#" naturalNeIdKey +naturalGeName = bnnVarQual "naturalGe#" naturalGeIdKey +naturalLeName = bnnVarQual "naturalLe#" naturalLeIdKey +naturalGtName = bnnVarQual "naturalGt#" naturalGtIdKey +naturalLtName = bnnVarQual "naturalLt#" naturalLtIdKey +naturalCompareName = bnnVarQual "naturalCompare" naturalCompareIdKey +naturalPopCountName = bnnVarQual "naturalPopCount#" naturalPopCountIdKey +naturalShiftRName = bnnVarQual "naturalShiftR#" naturalShiftRIdKey +naturalShiftLName = bnnVarQual "naturalShiftL#" naturalShiftLIdKey naturalAddName = bnnVarQual "naturalAdd" naturalAddIdKey -naturalSubName = bnnVarQual "naturalSubUnsafe" naturalSubIdKey +naturalSubName = bnnVarQual "naturalSub" naturalSubIdKey +naturalSubThrowName = bnnVarQual "naturalSubThrow" naturalSubThrowIdKey +naturalSubUnsafeName = bnnVarQual "naturalSubUnsafe" naturalSubUnsafeIdKey naturalMulName = bnnVarQual "naturalMul" naturalMulIdKey +naturalSignumName = bnnVarQual "naturalSignum" naturalSignumIdKey +naturalNegateName = bnnVarQual "naturalNegate" naturalNegateIdKey +naturalQuotRemName = bnnVarQual "naturalQuotRem#" naturalQuotRemIdKey naturalQuotName = bnnVarQual "naturalQuot" naturalQuotIdKey naturalRemName = bnnVarQual "naturalRem" naturalRemIdKey -naturalQuotRemName = bnnVarQual "naturalQuotRem" naturalQuotRemIdKey +naturalAndName = bnnVarQual "naturalAnd" naturalAndIdKey +naturalAndNotName = bnnVarQual "naturalAndNot" naturalAndNotIdKey +naturalOrName = bnnVarQual "naturalOr" naturalOrIdKey +naturalXorName = bnnVarQual "naturalXor" naturalXorIdKey +naturalTestBitName = bnnVarQual "naturalTestBit#" naturalTestBitIdKey +naturalBitName = bnnVarQual "naturalBit#" naturalBitIdKey +naturalGcdName = bnnVarQual "naturalGcd" naturalGcdIdKey +naturalLcmName = bnnVarQual "naturalLcm" naturalLcmIdKey +naturalLog2Name = bnnVarQual "naturalLog2#" naturalLog2IdKey +naturalLogBaseWordName = bnnVarQual "naturalLogBaseWord#" naturalLogBaseWordIdKey +naturalLogBaseName = bnnVarQual "naturalLogBase#" naturalLogBaseIdKey +naturalPowModName = bnnVarQual "naturalPowMod" naturalPowModIdKey +naturalSizeInBaseName = bnnVarQual "naturalSizeInBase#" naturalSizeInBaseIdKey integerFromNaturalName = bniVarQual "integerFromNatural" integerFromNaturalIdKey integerToNaturalClampName = bniVarQual "integerToNaturalClamp" integerToNaturalClampIdKey integerToNaturalThrowName = bniVarQual "integerToNaturalThrow" integerToNaturalThrowIdKey +integerToNaturalName = bniVarQual "integerToNatural" integerToNaturalIdKey integerToWordName = bniVarQual "integerToWord#" integerToWordIdKey integerToIntName = bniVarQual "integerToInt#" integerToIntIdKey integerToWord64Name = bniVarQual "integerToWord64#" integerToWord64IdKey @@ -1204,15 +1298,16 @@ integerAddName = bniVarQual "integerAdd" integerAddIdK integerMulName = bniVarQual "integerMul" integerMulIdKey integerSubName = bniVarQual "integerSub" integerSubIdKey integerNegateName = bniVarQual "integerNegate" integerNegateIdKey -integerEqPrimName = bniVarQual "integerEq#" integerEqPrimIdKey -integerNePrimName = bniVarQual "integerNe#" integerNePrimIdKey -integerLePrimName = bniVarQual "integerLe#" integerLePrimIdKey -integerGtPrimName = bniVarQual "integerGt#" integerGtPrimIdKey -integerLtPrimName = bniVarQual "integerLt#" integerLtPrimIdKey -integerGePrimName = bniVarQual "integerGe#" integerGePrimIdKey +integerEqName = bniVarQual "integerEq#" integerEqIdKey +integerNeName = bniVarQual "integerNe#" integerNeIdKey +integerLeName = bniVarQual "integerLe#" integerLeIdKey +integerGtName = bniVarQual "integerGt#" integerGtIdKey +integerLtName = bniVarQual "integerLt#" integerLtIdKey +integerGeName = bniVarQual "integerGe#" integerGeIdKey integerAbsName = bniVarQual "integerAbs" integerAbsIdKey integerSignumName = bniVarQual "integerSignum" integerSignumIdKey integerCompareName = bniVarQual "integerCompare" integerCompareIdKey +integerPopCountName = bniVarQual "integerPopCount#" integerPopCountIdKey integerQuotName = bniVarQual "integerQuot" integerQuotIdKey integerRemName = bniVarQual "integerRem" integerRemIdKey integerDivName = bniVarQual "integerDiv" integerDivIdKey @@ -1230,6 +1325,7 @@ integerOrName = bniVarQual "integerOr" integerOrIdKe integerXorName = bniVarQual "integerXor" integerXorIdKey integerComplementName = bniVarQual "integerComplement" integerComplementIdKey integerBitName = bniVarQual "integerBit#" integerBitIdKey +integerTestBitName = bniVarQual "integerTestBit#" integerTestBitIdKey integerShiftLName = bniVarQual "integerShiftL#" integerShiftLIdKey integerShiftRName = bniVarQual "integerShiftR#" integerShiftRIdKey @@ -2427,6 +2523,7 @@ unsafeCoercePrimIdKey = mkPreludeMiscIdUnique 571 integerFromNaturalIdKey , integerToNaturalClampIdKey , integerToNaturalThrowIdKey + , integerToNaturalIdKey , integerToWordIdKey , integerToIntIdKey , integerToWord64IdKey @@ -2435,15 +2532,16 @@ integerFromNaturalIdKey , integerMulIdKey , integerSubIdKey , integerNegateIdKey - , integerEqPrimIdKey - , integerNePrimIdKey - , integerLePrimIdKey - , integerGtPrimIdKey - , integerLtPrimIdKey - , integerGePrimIdKey + , integerEqIdKey + , integerNeIdKey + , integerLeIdKey + , integerGtIdKey + , integerLtIdKey + , integerGeIdKey , integerAbsIdKey , integerSignumIdKey , integerCompareIdKey + , integerPopCountIdKey , integerQuotIdKey , integerRemIdKey , integerDivIdKey @@ -2461,73 +2559,133 @@ integerFromNaturalIdKey , integerXorIdKey , integerComplementIdKey , integerBitIdKey + , integerTestBitIdKey , integerShiftLIdKey , integerShiftRIdKey , integerFromWordIdKey , integerFromWord64IdKey , integerFromInt64IdKey , naturalToWordIdKey + , naturalToWordClampIdKey + , naturalEqIdKey + , naturalNeIdKey + , naturalGeIdKey + , naturalLeIdKey + , naturalGtIdKey + , naturalLtIdKey + , naturalCompareIdKey + , naturalPopCountIdKey + , naturalShiftRIdKey + , naturalShiftLIdKey , naturalAddIdKey , naturalSubIdKey + , naturalSubThrowIdKey + , naturalSubUnsafeIdKey , naturalMulIdKey + , naturalSignumIdKey + , naturalNegateIdKey + , naturalQuotRemIdKey , naturalQuotIdKey , naturalRemIdKey - , naturalQuotRemIdKey + , naturalAndIdKey + , naturalAndNotIdKey + , naturalOrIdKey + , naturalXorIdKey + , naturalTestBitIdKey + , naturalBitIdKey + , naturalGcdIdKey + , naturalLcmIdKey + , naturalLog2IdKey + , naturalLogBaseWordIdKey + , naturalLogBaseIdKey + , naturalPowModIdKey + , naturalSizeInBaseIdKey , bignatFromWordListIdKey :: Unique integerFromNaturalIdKey = mkPreludeMiscIdUnique 600 integerToNaturalClampIdKey = mkPreludeMiscIdUnique 601 integerToNaturalThrowIdKey = mkPreludeMiscIdUnique 602 -integerToWordIdKey = mkPreludeMiscIdUnique 603 -integerToIntIdKey = mkPreludeMiscIdUnique 604 -integerToWord64IdKey = mkPreludeMiscIdUnique 605 -integerToInt64IdKey = mkPreludeMiscIdUnique 606 -integerAddIdKey = mkPreludeMiscIdUnique 607 -integerMulIdKey = mkPreludeMiscIdUnique 608 -integerSubIdKey = mkPreludeMiscIdUnique 609 -integerNegateIdKey = mkPreludeMiscIdUnique 610 -integerEqPrimIdKey = mkPreludeMiscIdUnique 611 -integerNePrimIdKey = mkPreludeMiscIdUnique 612 -integerLePrimIdKey = mkPreludeMiscIdUnique 613 -integerGtPrimIdKey = mkPreludeMiscIdUnique 614 -integerLtPrimIdKey = mkPreludeMiscIdUnique 615 -integerGePrimIdKey = mkPreludeMiscIdUnique 616 -integerAbsIdKey = mkPreludeMiscIdUnique 617 -integerSignumIdKey = mkPreludeMiscIdUnique 618 -integerCompareIdKey = mkPreludeMiscIdUnique 619 -integerQuotIdKey = mkPreludeMiscIdUnique 620 -integerRemIdKey = mkPreludeMiscIdUnique 621 -integerDivIdKey = mkPreludeMiscIdUnique 622 -integerModIdKey = mkPreludeMiscIdUnique 623 -integerDivModIdKey = mkPreludeMiscIdUnique 624 -integerQuotRemIdKey = mkPreludeMiscIdUnique 625 -integerToFloatIdKey = mkPreludeMiscIdUnique 626 -integerToDoubleIdKey = mkPreludeMiscIdUnique 627 -integerEncodeFloatIdKey = mkPreludeMiscIdUnique 628 -integerEncodeDoubleIdKey = mkPreludeMiscIdUnique 629 -integerGcdIdKey = mkPreludeMiscIdUnique 630 -integerLcmIdKey = mkPreludeMiscIdUnique 631 -integerAndIdKey = mkPreludeMiscIdUnique 632 -integerOrIdKey = mkPreludeMiscIdUnique 633 -integerXorIdKey = mkPreludeMiscIdUnique 634 -integerComplementIdKey = mkPreludeMiscIdUnique 635 -integerBitIdKey = mkPreludeMiscIdUnique 636 -integerShiftLIdKey = mkPreludeMiscIdUnique 637 -integerShiftRIdKey = mkPreludeMiscIdUnique 638 -integerFromWordIdKey = mkPreludeMiscIdUnique 639 -integerFromWord64IdKey = mkPreludeMiscIdUnique 640 -integerFromInt64IdKey = mkPreludeMiscIdUnique 641 +integerToNaturalIdKey = mkPreludeMiscIdUnique 603 +integerToWordIdKey = mkPreludeMiscIdUnique 604 +integerToIntIdKey = mkPreludeMiscIdUnique 605 +integerToWord64IdKey = mkPreludeMiscIdUnique 606 +integerToInt64IdKey = mkPreludeMiscIdUnique 607 +integerAddIdKey = mkPreludeMiscIdUnique 608 +integerMulIdKey = mkPreludeMiscIdUnique 609 +integerSubIdKey = mkPreludeMiscIdUnique 610 +integerNegateIdKey = mkPreludeMiscIdUnique 611 +integerEqIdKey = mkPreludeMiscIdUnique 612 +integerNeIdKey = mkPreludeMiscIdUnique 613 +integerLeIdKey = mkPreludeMiscIdUnique 614 +integerGtIdKey = mkPreludeMiscIdUnique 615 +integerLtIdKey = mkPreludeMiscIdUnique 616 +integerGeIdKey = mkPreludeMiscIdUnique 617 +integerAbsIdKey = mkPreludeMiscIdUnique 618 +integerSignumIdKey = mkPreludeMiscIdUnique 619 +integerCompareIdKey = mkPreludeMiscIdUnique 620 +integerPopCountIdKey = mkPreludeMiscIdUnique 621 +integerQuotIdKey = mkPreludeMiscIdUnique 622 +integerRemIdKey = mkPreludeMiscIdUnique 623 +integerDivIdKey = mkPreludeMiscIdUnique 624 +integerModIdKey = mkPreludeMiscIdUnique 625 +integerDivModIdKey = mkPreludeMiscIdUnique 626 +integerQuotRemIdKey = mkPreludeMiscIdUnique 627 +integerToFloatIdKey = mkPreludeMiscIdUnique 628 +integerToDoubleIdKey = mkPreludeMiscIdUnique 629 +integerEncodeFloatIdKey = mkPreludeMiscIdUnique 630 +integerEncodeDoubleIdKey = mkPreludeMiscIdUnique 631 +integerGcdIdKey = mkPreludeMiscIdUnique 632 +integerLcmIdKey = mkPreludeMiscIdUnique 633 +integerAndIdKey = mkPreludeMiscIdUnique 634 +integerOrIdKey = mkPreludeMiscIdUnique 635 +integerXorIdKey = mkPreludeMiscIdUnique 636 +integerComplementIdKey = mkPreludeMiscIdUnique 637 +integerBitIdKey = mkPreludeMiscIdUnique 638 +integerTestBitIdKey = mkPreludeMiscIdUnique 639 +integerShiftLIdKey = mkPreludeMiscIdUnique 640 +integerShiftRIdKey = mkPreludeMiscIdUnique 641 +integerFromWordIdKey = mkPreludeMiscIdUnique 642 +integerFromWord64IdKey = mkPreludeMiscIdUnique 643 +integerFromInt64IdKey = mkPreludeMiscIdUnique 644 naturalToWordIdKey = mkPreludeMiscIdUnique 650 -naturalAddIdKey = mkPreludeMiscIdUnique 651 -naturalSubIdKey = mkPreludeMiscIdUnique 652 -naturalMulIdKey = mkPreludeMiscIdUnique 653 -naturalQuotIdKey = mkPreludeMiscIdUnique 654 -naturalRemIdKey = mkPreludeMiscIdUnique 655 -naturalQuotRemIdKey = mkPreludeMiscIdUnique 656 - -bignatFromWordListIdKey = mkPreludeMiscIdUnique 670 +naturalToWordClampIdKey = mkPreludeMiscIdUnique 651 +naturalEqIdKey = mkPreludeMiscIdUnique 652 +naturalNeIdKey = mkPreludeMiscIdUnique 653 +naturalGeIdKey = mkPreludeMiscIdUnique 654 +naturalLeIdKey = mkPreludeMiscIdUnique 655 +naturalGtIdKey = mkPreludeMiscIdUnique 656 +naturalLtIdKey = mkPreludeMiscIdUnique 657 +naturalCompareIdKey = mkPreludeMiscIdUnique 658 +naturalPopCountIdKey = mkPreludeMiscIdUnique 659 +naturalShiftRIdKey = mkPreludeMiscIdUnique 660 +naturalShiftLIdKey = mkPreludeMiscIdUnique 661 +naturalAddIdKey = mkPreludeMiscIdUnique 662 +naturalSubIdKey = mkPreludeMiscIdUnique 663 +naturalSubThrowIdKey = mkPreludeMiscIdUnique 664 +naturalSubUnsafeIdKey = mkPreludeMiscIdUnique 665 +naturalMulIdKey = mkPreludeMiscIdUnique 666 +naturalSignumIdKey = mkPreludeMiscIdUnique 667 +naturalNegateIdKey = mkPreludeMiscIdUnique 668 +naturalQuotRemIdKey = mkPreludeMiscIdUnique 669 +naturalQuotIdKey = mkPreludeMiscIdUnique 670 +naturalRemIdKey = mkPreludeMiscIdUnique 671 +naturalAndIdKey = mkPreludeMiscIdUnique 672 +naturalAndNotIdKey = mkPreludeMiscIdUnique 673 +naturalOrIdKey = mkPreludeMiscIdUnique 674 +naturalXorIdKey = mkPreludeMiscIdUnique 675 +naturalTestBitIdKey = mkPreludeMiscIdUnique 676 +naturalBitIdKey = mkPreludeMiscIdUnique 677 +naturalGcdIdKey = mkPreludeMiscIdUnique 678 +naturalLcmIdKey = mkPreludeMiscIdUnique 679 +naturalLog2IdKey = mkPreludeMiscIdUnique 680 +naturalLogBaseWordIdKey = mkPreludeMiscIdUnique 681 +naturalLogBaseIdKey = mkPreludeMiscIdUnique 682 +naturalPowModIdKey = mkPreludeMiscIdUnique 683 +naturalSizeInBaseIdKey = mkPreludeMiscIdUnique 684 + +bignatFromWordListIdKey = mkPreludeMiscIdUnique 690 {- ************************************************************************ diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs index cc67143fba..b2dc4f4555 100644 --- a/compiler/GHC/Core/Make.hs +++ b/compiler/GHC/Core/Make.hs @@ -23,7 +23,7 @@ module GHC.Core.Make ( FloatBind(..), wrapFloat, wrapFloats, floatBindings, -- * Constructing small tuples - mkCoreVarTupTy, mkCoreTup, mkCoreUbxTup, + mkCoreVarTupTy, mkCoreTup, mkCoreUbxTup, mkCoreUbxSum, mkCoreTupBoxity, unitExpr, -- * Constructing big tuples @@ -402,6 +402,18 @@ mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr mkCoreTupBoxity Boxed exps = mkCoreTup1 exps mkCoreTupBoxity Unboxed exps = mkCoreUbxTup (map exprType exps) exps +-- | Build an unboxed sum. +-- +-- Alternative number ("alt") starts from 1. +mkCoreUbxSum :: Int -> Int -> [Type] -> CoreExpr -> CoreExpr +mkCoreUbxSum arity alt tys exp + = ASSERT( length tys == arity ) + ASSERT( alt <= arity ) + mkCoreConApps (sumDataCon alt arity) + (map (Type . getRuntimeRep) tys + ++ map Type tys + ++ [exp]) + -- | Build a big tuple holding the specified variables -- One-tuples are flattened; see Note [Flattening one-tuples] mkBigCoreVarTup :: [Id] -> CoreExpr diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs index a4bc764d28..dfb24b6cc4 100644 --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/compiler/GHC/Core/Opt/ConstantFold.hs @@ -45,7 +45,7 @@ import GHC.Prelude import GHC.Driver.Ppr -import {-# SOURCE #-} GHC.Types.Id.Make ( mkPrimOpId, magicDictId ) +import {-# SOURCE #-} GHC.Types.Id.Make ( mkPrimOpId, magicDictId, voidPrimId ) import GHC.Core import GHC.Core.Make @@ -1149,9 +1149,7 @@ There are two cases: We are happy to shift by any amount up to wordSize but no more. -- Shifting Integers: the function shiftLInteger, shiftRInteger - from the 'integer' library. These are handled by rule_shift_op, - and match_Integer_shift_op. +- Shifting Bignums (Integer, Natural): these are handled by bignum_shift. Here we could in principle shift by any amount, but we arbitrary limit the shift to 4 bits; in particular we do not want shift by a @@ -1239,6 +1237,38 @@ getInScopeEnv = RuleM $ \_ iu _ _ -> Just iu getFunction :: RuleM Id getFunction = RuleM $ \_ _ fn _ -> Just fn +isLiteral :: CoreExpr -> RuleM Literal +isLiteral e = do + env <- getInScopeEnv + case exprIsLiteral_maybe env e of + Nothing -> mzero + Just l -> pure l + +isNumberLiteral :: CoreExpr -> RuleM Integer +isNumberLiteral e = isLiteral e >>= \case + LitNumber _ x -> pure x + _ -> mzero + +isIntegerLiteral :: CoreExpr -> RuleM Integer +isIntegerLiteral e = isLiteral e >>= \case + LitNumber LitNumInteger x -> pure x + _ -> 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 + -- return the n-th argument of this rule, if it is a literal -- argument indices start from 0 getLiteral :: Int -> RuleM Literal @@ -1697,126 +1727,333 @@ builtinRules enableBignumRules builtinBignumRules :: EnableBignumRules -> [CoreRule] builtinBignumRules (EnableBignumRules False) = [] builtinBignumRules _ = - [ rule_IntegerFromLitNum "Word# -> Integer" integerFromWordName - , rule_IntegerFromLitNum "Int64# -> Integer" integerFromInt64Name - , rule_IntegerFromLitNum "Word64# -> Integer" integerFromWord64Name - , rule_IntegerFromLitNum "Natural -> Integer" integerFromNaturalName - , rule_convert "Integer -> Word#" integerToWordName mkWordLitWrap - , rule_convert "Integer -> Int#" integerToIntName mkIntLitWrap - , rule_convert "Integer -> Word64#" integerToWord64Name (\_ -> mkWord64LitWord64 . fromInteger) - , rule_convert "Integer -> Int64#" integerToInt64Name (\_ -> mkInt64LitInt64 . fromInteger) - , rule_binopi "integerAdd" integerAddName (+) - , rule_binopi "integerSub" integerSubName (-) - , rule_binopi "integerMul" integerMulName (*) - , rule_unop "integerNegate" integerNegateName negate - , rule_binop_Prim "integerEq#" integerEqPrimName (==) - , rule_binop_Prim "integerNe#" integerNePrimName (/=) - , rule_binop_Prim "integerLe#" integerLePrimName (<=) - , rule_binop_Prim "integerGt#" integerGtPrimName (>) - , rule_binop_Prim "integerLt#" integerLtPrimName (<) - , rule_binop_Prim "integerGe#" integerGePrimName (>=) - , rule_unop "integerAbs" integerAbsName abs - , rule_unop "integerSignum" integerSignumName signum - , rule_binop_Ordering "integerCompare" integerCompareName compare - , rule_encodeFloat "integerEncodeFloat" integerEncodeFloatName mkFloatLitFloat - , rule_convert "integerToFloat" integerToFloatName (\_ -> mkFloatLitFloat . fromInteger) - , rule_encodeFloat "integerEncodeDouble" integerEncodeDoubleName mkDoubleLitDouble - , rule_convert "integerToDouble" integerToDoubleName (\_ -> mkDoubleLitDouble . fromInteger) - , rule_binopi "integerGcd" integerGcdName gcd - , rule_binopi "integerLcm" integerLcmName lcm - , rule_binopi "integerAnd" integerAndName (.&.) - , rule_binopi "integerOr" integerOrName (.|.) - , rule_binopi "integerXor" integerXorName xor - , rule_unop "integerComplement" integerComplementName complement - , rule_shift_op "integerShiftL" integerShiftLName shiftL - , rule_shift_op "integerShiftR" integerShiftRName shiftR - , rule_integerBit "integerBit" integerBitName - -- See Note [Integer division constant folding] in libraries/base/GHC/Real.hs - , rule_divop_one "integerQuot" integerQuotName quot - , rule_divop_one "integerRem" integerRemName rem - , rule_divop_one "integerDiv" integerDivName div - , rule_divop_one "integerMod" integerModName mod - , rule_divop_both "integerDivMod" integerDivModName divMod - , rule_divop_both "integerQuotRem" integerQuotRemName quotRem - - -- These rules below don't actually have to be built in, but if we - -- put them in the Haskell source then we'd have to duplicate them - -- between all Integer implementations - -- TODO: let's put them into ghc-bignum package or remove them and let the - -- inliner do the job - , rule_passthrough "Int# -> Integer -> Int#" integerToIntName integerISDataConName - , rule_passthrough "Word# -> Integer -> Word#" integerToWordName integerFromWordName - , rule_passthrough "Int64# -> Integer -> Int64#" integerToInt64Name integerFromInt64Name - , rule_passthrough "Word64# -> Integer -> Word64#" integerToWord64Name integerFromWord64Name - , rule_smallIntegerTo "IS -> Word#" integerToWordName IntToWordOp - , rule_smallIntegerTo "IS -> Float" integerToFloatName IntToFloatOp - , rule_smallIntegerTo "IS -> Double" integerToDoubleName IntToDoubleOp - , rule_passthrough "Word# -> Natural -> Word#" naturalToWordName naturalNSDataConName - - , rule_IntegerToNaturalClamp "Integer -> Natural (clamp)" integerToNaturalClampName - , rule_IntegerToNaturalThrow "Integer -> Natural (throw)" integerToNaturalThrowName - , rule_binopn "naturalAdd" naturalAddName (+) - , rule_partial_binopn "naturalSub" naturalSubName (\a b -> if a >= b then Just (a - b) else Nothing) - , rule_binopn "naturalMul" naturalMulName (*) - - -- TODO: why is that here? - , rule_rationalTo "rationalToFloat" rationalToFloatName mkFloatExpr - , rule_rationalTo "rationalToDouble" rationalToDoubleName mkDoubleExpr - ] - where rule_convert str name convert - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_Integer_convert convert } - rule_IntegerFromLitNum str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_LitNumToInteger } - rule_unop str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_Integer_unop op } - rule_integerBit str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_integerBit } - rule_binopi str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_binop op } - rule_divop_both str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_divop_both op } - rule_divop_one str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_divop_one op } - rule_shift_op str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_shift_op op } - rule_binop_Prim str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_binop_Prim op } - rule_binop_Ordering str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_binop_Ordering op } - rule_encodeFloat str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_Int_encodeFloat op } - rule_passthrough str name toIntegerName - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_passthrough toIntegerName } - rule_smallIntegerTo str name primOp - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_smallIntegerTo primOp } - rule_rationalTo str name mkLit - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_rationalTo mkLit } - rule_IntegerToNaturalClamp str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_IntegerToNaturalClamp } - rule_IntegerToNaturalThrow str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_IntegerToNaturalThrow } - rule_binopn str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Natural_binop op } - rule_partial_binopn str name op - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Natural_partial_binop op } + [ -- conversions + lit_to_integer "Word# -> Integer" integerFromWordName + , lit_to_integer "Int64# -> Integer" integerFromInt64Name + , lit_to_integer "Word64# -> Integer" integerFromWord64Name + , lit_to_integer "Natural -> Integer" integerFromNaturalName + + , integer_to_lit "Integer -> Word# (wrap)" integerToWordName mkWordLitWrap + , integer_to_lit "Integer -> Int# (wrap)" integerToIntName mkIntLitWrap + , integer_to_lit "Integer -> Word64# (wrap)" integerToWord64Name (\_ -> mkWord64LitWord64 . fromInteger) + , integer_to_lit "Integer -> Int64# (wrap)" integerToInt64Name (\_ -> mkInt64LitInt64 . fromInteger) + , integer_to_lit "Integer -> Float#" integerToFloatName (\_ -> mkFloatLitFloat . fromInteger) + , integer_to_lit "Integer -> Double#" integerToDoubleName (\_ -> mkDoubleLitDouble . fromInteger) + + , integer_to_natural "Integer -> Natural (clamp)" integerToNaturalClampName False True + , integer_to_natural "Integer -> Natural (wrap)" integerToNaturalName False False + , integer_to_natural "Integer -> Natural (throw)" integerToNaturalThrowName True False + + , lit_to_natural "Word# -> Natural" naturalNSDataConName + , natural_to_word "Natural -> Word# (wrap)" naturalToWordName False + , natural_to_word "Natural -> Word# (clamp)" naturalToWordClampName True + + -- comparisons (return an unlifted Int#) + , integer_cmp "integerEq#" integerEqName (==) + , integer_cmp "integerNe#" integerNeName (/=) + , integer_cmp "integerLe#" integerLeName (<=) + , integer_cmp "integerGt#" integerGtName (>) + , integer_cmp "integerLt#" integerLtName (<) + , integer_cmp "integerGe#" integerGeName (>=) + + , natural_cmp "naturalEq#" naturalEqName (==) + , natural_cmp "naturalNe#" naturalNeName (/=) + , natural_cmp "naturalLe#" naturalLeName (<=) + , natural_cmp "naturalGt#" naturalGtName (>) + , natural_cmp "naturalLt#" naturalLtName (<) + , natural_cmp "naturalGe#" naturalGeName (>=) + + -- comparisons (return an Ordering) + , bignum_compare "integerCompare" integerCompareName + , bignum_compare "naturalCompare" naturalCompareName + + -- binary operations + , integer_binop "integerAdd" integerAddName (+) + , integer_binop "integerSub" integerSubName (-) + , integer_binop "integerMul" integerMulName (*) + , integer_binop "integerGcd" integerGcdName gcd + , integer_binop "integerLcm" integerLcmName lcm + , integer_binop "integerAnd" integerAndName (.&.) + , integer_binop "integerOr" integerOrName (.|.) + , integer_binop "integerXor" integerXorName xor + + , natural_binop "naturalAdd" naturalAddName (+) + , natural_binop "naturalMul" naturalMulName (*) + , natural_binop "naturalGcd" naturalGcdName gcd + , natural_binop "naturalLcm" naturalLcmName lcm + , natural_binop "naturalAnd" naturalAndName (.&.) + , natural_binop "naturalOr" naturalOrName (.|.) + , natural_binop "naturalXor" naturalXorName xor + + -- Natural subtraction: it's a binop but it can fail because of underflow so + -- we have several primitives to handle here. + , natural_sub "naturalSubUnsafe" naturalSubUnsafeName + , natural_sub "naturalSubThrow" naturalSubThrowName + , mkRule "naturalSub" naturalSubName 2 $ do + [a0,a1] <- getArgs + x <- isNaturalLiteral a0 + y <- isNaturalLiteral a1 + -- return an unboxed sum: (# (# #) | Natural #) + let ret n v = pure $ mkCoreUbxSum 2 n [unboxedUnitTy,naturalTy] v + if x < y + then ret 1 $ Var voidPrimId + else ret 2 $ Lit (mkLitNatural (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 "naturalSignum" naturalSignumName mkLitNatural signum + + , mkRule "naturalNegate" naturalNegateName 1 $ do + [a0] <- getArgs + x <- isNaturalLiteral a0 + guard (x == 0) -- negate is only valid for (0 :: Natural) + pure a0 + + , bignum_popcount "integerPopCount" integerPopCountName mkLitIntWrap + , bignum_popcount "naturalPopCount" naturalPopCountName mkLitWordWrap + + -- identity passthrough + , id_passthrough "Int# -> Integer -> Int#" integerToIntName integerISDataConName + , id_passthrough "Word# -> Integer -> Word#" integerToWordName integerFromWordName + , id_passthrough "Int64# -> Integer -> Int64#" integerToInt64Name integerFromInt64Name + , id_passthrough "Word64# -> Integer -> Word64#" integerToWord64Name integerFromWord64Name + , id_passthrough "Word# -> Natural -> Word#" naturalToWordName naturalNSDataConName + + -- identity passthrough with a conversion that can be done directly instead + , small_passthrough "Int# -> Integer -> Word#" + integerISDataConName integerToWordName (mkPrimOpId IntToWordOp) + , small_passthrough "Int# -> Integer -> Float#" + integerISDataConName integerToFloatName (mkPrimOpId IntToFloatOp) + , small_passthrough "Int# -> Integer -> Double#" + integerISDataConName integerToDoubleName (mkPrimOpId IntToDoubleOp) + , small_passthrough "Word# -> Natural -> Int#" + naturalNSDataConName naturalToWordName (mkPrimOpId WordToIntOp) + + -- Bits.bit + , bignum_bit "integerBit" integerBitName mkLitInteger + , bignum_bit "naturalBit" naturalBitName mkLitNatural + + -- 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 + + -- 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 "naturalQuot" naturalQuotName quot mkLitNatural + , divop_one "naturalRem" naturalRemName rem mkLitNatural + , divop_both "naturalQuotRem" naturalQuotRemName quotRem mkLitNatural naturalTy + + -- conversions from Rational for Float/Double literals + , rational_to "rationalToFloat" rationalToFloatName mkFloatExpr + , rational_to "rationalToDouble" rationalToDoubleName mkDoubleExpr + + -- conversions from Integer for Float/Double literals + , integer_encode_float "integerEncodeFloat" integerEncodeFloatName mkFloatLitFloat + , integer_encode_float "integerEncodeDouble" integerEncodeDoubleName mkDoubleLitDouble + ] + where + mkRule str name nargs f = BuiltinRule + { ru_name = fsLit str + , ru_fn = name + , ru_nargs = nargs + , ru_try = runRuleM f + } + + integer_to_lit str name convert = mkRule str name 1 $ do + [a0] <- getArgs + platform <- getPlatform + x <- isIntegerLiteral a0 + pure (convert platform x) + + natural_to_word str name clamp = mkRule str name 1 $ do + [a0] <- getArgs + n <- isNaturalLiteral a0 + platform <- getPlatform + if clamp && not (platformInWordRange platform n) + then pure (Lit (mkLitWord platform (platformMaxWord platform))) + else pure (Lit (mkLitWordWrap platform n)) + + integer_to_natural str name thrw clamp = mkRule str name 1 $ do + [a0] <- getArgs + x <- isIntegerLiteral a0 + if | x >= 0 -> pure $ Lit $ mkLitNatural x + | thrw -> mzero + | clamp -> pure $ Lit $ mkLitNatural 0 -- clamp to 0 + | otherwise -> pure $ Lit $ mkLitNatural (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 + + lit_to_natural str name = mkRule str name 1 $ do + [a0] <- getArgs + isLiteral a0 >>= \case + -- convert any *positive* numeric literal into a Natural literal + LitNumber _ i | i >= 0 -> pure (Lit (mkLitNatural i)) + _ -> mzero + + 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))) + + 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))) + + 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))) + + integer_cmp str name op = mkRule str name 2 $ do + platform <- getPlatform + [a0,a1] <- getArgs + x <- isIntegerLiteral a0 + y <- isIntegerLiteral a1 + pure $ if x `op` y + then trueValInt platform + else falseValInt platform + + natural_cmp str name op = mkRule str name 2 $ do + platform <- getPlatform + [a0,a1] <- getArgs + x <- isNaturalLiteral a0 + y <- isNaturalLiteral a1 + pure $ if x `op` y + then trueValInt platform + else falseValInt platform + + bignum_compare str name = mkRule str name 2 $ do + [a0,a1] <- getArgs + x <- isNumberLiteral a0 + y <- isNumberLiteral a1 + pure $ case x `compare` y of + LT -> ltVal + EQ -> eqVal + GT -> gtVal + + bignum_unop str name mk_lit op = mkRule str name 1 $ do + [a0] <- getArgs + x <- isNumberLiteral a0 + pure $ Lit (mk_lit (op x)) + + bignum_popcount str name mk_lit = mkRule str name 1 $ do + platform <- getPlatform + -- We use a host Int to compute the popCount. If we compile on a 32-bit + -- host for a 64-bit target, the result may be different than if computed + -- by the target. So we disable this rule if sizes don't match. + guard (platformWordSizeInBits platform == finiteBitSize (0 :: Word)) + [a0] <- getArgs + x <- isNumberLiteral a0 + pure $ Lit (mk_lit platform (fromIntegral (popCount x))) + + id_passthrough str to_x from_x = mkRule str to_x 1 $ do + [App (Var f) x] <- getArgs + guard (idName f == from_x) + pure x + + small_passthrough str from_x to_y x_to_y = mkRule str to_y 1 $ do + [App (Var f) x] <- getArgs + guard (idName f == from_x) + pure $ App (Var x_to_y) x + + bignum_bit str name mk_lit = mkRule str name 1 $ do + [a0] <- getArgs + platform <- getPlatform + n <- isNumberLiteral a0 + -- Make sure n is positive and small enough to yield a decently + -- small number. Attempting to construct the Integer for + -- (integerBit 9223372036854775807#) + -- would be a bad idea (#14959) + 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))) + + bignum_testbit str name = mkRule str name 2 $ do + [a0,a1] <- getArgs + platform <- getPlatform + x <- isNumberLiteral a0 + n <- isNumberLiteral a1 + -- ensure that we can store 'n' in a host Int + guard (n >= 0 && n <= fromIntegral (maxBound :: Int)) + pure $ if testBit x (fromIntegral n) + then trueValInt platform + else falseValInt platform + + bignum_shift str name shift_op mk_lit = mkRule str name 2 $ do + [a0,a1] <- getArgs + x <- isNumberLiteral a0 + n <- isWordLiteral 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)) + + divop_one str name divop mk_lit = mkRule str name 2 $ do + [a0,a1] <- getArgs + n <- isNumberLiteral a0 + d <- isNumberLiteral a1 + guard (d /= 0) + pure $ Lit (mk_lit (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 + guard (d /= 0) + let (r,s) = n `divop` d + pure $ mkCoreUbxTup [ty,ty] [Lit (mk_lit r), Lit (mk_lit 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 + -- check that y (a target Int) is in the host Int range + guard (y <= fromIntegral (maxBound :: Int)) + pure (mk_lit $ encodeFloat x (fromInteger y)) + + rational_to :: RealFloat a => String -> Name -> (a -> CoreExpr) -> CoreRule + rational_to str name mk_lit = mkRule str name 2 $ do + -- This turns `rationalToFloat n d` where `n` and `d` are literals into + -- a literal Float (and similarly for Double). + [a0,a1] <- getArgs + n <- isIntegerLiteral a0 + d <- isIntegerLiteral a1 + -- it's important to not match d == 0, because that may represent a + -- literal "0/0" or similar, and we can't produce a literal value for + -- NaN or +-Inf + guard (d /= 0) + pure $ mk_lit (fromRational (n % d)) + + --------------------------------------------------- -- The rule is this: @@ -1969,190 +2206,6 @@ match_magicDict [Type _, Var wrap `App` Type a `App` Type _ `App` f, x, y ] match_magicDict _ = Nothing -match_LitNumToInteger :: RuleFun -match_LitNumToInteger _ id_unf _ [xl] - | Just (LitNumber _ x) <- exprIsLiteral_maybe id_unf xl - = Just (Lit (mkLitInteger x)) -match_LitNumToInteger _ _ _ _ = Nothing - -match_IntegerToNaturalClamp :: RuleFun -match_IntegerToNaturalClamp _ id_unf _ [xl] - | Just (LitNumber LitNumInteger x) <- exprIsLiteral_maybe id_unf xl - = if x >= 0 - then Just (Lit (mkLitNatural x)) - else Just (Lit (mkLitNatural 0)) -match_IntegerToNaturalClamp _ _ _ _ = Nothing - -match_IntegerToNaturalThrow :: RuleFun -match_IntegerToNaturalThrow _ id_unf _ [xl] - | Just (LitNumber LitNumInteger x) <- exprIsLiteral_maybe id_unf xl - = if x >= 0 - then Just (Lit (mkLitNatural x)) - else Nothing -match_IntegerToNaturalThrow _ _ _ _ = Nothing - -------------------------------------------------- -{- Note [Rewriting integerBit] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For most types the integerBit operation can be implemented in terms of shifts. -The ghc-bignum package, however, can do substantially better than this if -allowed to provide its own implementation. However, in so doing it previously lost -constant-folding (see #8832). The integerBit rule above provides constant folding -specifically for this function. - -There is, however, a bit of trickiness here when it comes to ranges. While the -AST encodes all integers as Integers, `bit` expects the bit -index to be given as an Int. Hence we coerce to an Int in the rule definition. -This will behave a bit funny for constants larger than the word size, but the user -should expect some funniness given that they will have at very least ignored a -warning in this case. --} - --- | Constant folding for `GHC.Num.Integer.integerBit# :: Word# -> Integer` -match_integerBit :: RuleFun -match_integerBit env id_unf _fn [arg] - | Just (LitNumber _ x) <- exprIsLiteral_maybe id_unf arg - , x >= 0 - , x <= fromIntegral (platformWordSizeInBits (roPlatform env)) - -- Make sure x is small enough to yield a decently small integer - -- Attempting to construct the Integer for - -- (integerBit 9223372036854775807#) - -- would be a bad idea (#14959) - , let x_int = fromIntegral x :: Int - = Just (Lit (mkLitInteger (bit x_int))) -match_integerBit _ _ _ _ = Nothing - - -------------------------------------------------- -match_Integer_convert :: (Platform -> Integer -> Expr CoreBndr) - -> RuleFun -match_Integer_convert convert env id_unf _ [xl] - | Just (LitNumber LitNumInteger x) <- exprIsLiteral_maybe id_unf xl - = Just (convert (roPlatform env) x) -match_Integer_convert _ _ _ _ _ = Nothing - -match_Integer_unop :: (Integer -> Integer) -> RuleFun -match_Integer_unop unop _ id_unf _ [xl] - | Just (LitNumber LitNumInteger x) <- exprIsLiteral_maybe id_unf xl - = Just (Lit (LitNumber LitNumInteger (unop x))) -match_Integer_unop _ _ _ _ _ = Nothing - -match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun -match_Integer_binop binop _ id_unf _ [xl,yl] - | Just (LitNumber LitNumInteger x) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumInteger y) <- exprIsLiteral_maybe id_unf yl - = Just (Lit (mkLitInteger (x `binop` y))) -match_Integer_binop _ _ _ _ _ = Nothing - -match_Natural_binop :: (Integer -> Integer -> Integer) -> RuleFun -match_Natural_binop binop _ id_unf _ [xl,yl] - | Just (LitNumber LitNumNatural x) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumNatural y) <- exprIsLiteral_maybe id_unf yl - = Just (Lit (mkLitNatural (x `binop` y))) -match_Natural_binop _ _ _ _ _ = Nothing - -match_Natural_partial_binop :: (Integer -> Integer -> Maybe Integer) -> RuleFun -match_Natural_partial_binop binop _ id_unf _ [xl,yl] - | Just (LitNumber LitNumNatural x) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumNatural y) <- exprIsLiteral_maybe id_unf yl - , Just z <- x `binop` y - = Just (Lit (mkLitNatural z)) -match_Natural_partial_binop _ _ _ _ _ = Nothing - --- This helper is used for the quotRem and divMod functions -match_Integer_divop_both - :: (Integer -> Integer -> (Integer, Integer)) -> RuleFun -match_Integer_divop_both divop _ id_unf _ [xl,yl] - | Just (LitNumber LitNumInteger x) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumInteger y) <- exprIsLiteral_maybe id_unf yl - , y /= 0 - , (r,s) <- x `divop` y - = Just $ mkCoreUbxTup [integerTy,integerTy] - [Lit (mkLitInteger r), Lit (mkLitInteger s)] -match_Integer_divop_both _ _ _ _ _ = Nothing - --- This helper is used for the quot and rem functions -match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun -match_Integer_divop_one divop _ id_unf _ [xl,yl] - | Just (LitNumber LitNumInteger x) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumInteger y) <- exprIsLiteral_maybe id_unf yl - , y /= 0 - = Just (Lit (mkLitInteger (x `divop` y))) -match_Integer_divop_one _ _ _ _ _ = Nothing - -match_Integer_shift_op :: (Integer -> Int -> Integer) -> RuleFun --- Used for integerShiftL#, integerShiftR :: Integer -> Word# -> Integer --- See Note [Guarding against silly shifts] -match_Integer_shift_op binop _ id_unf _ [xl,yl] - | Just (LitNumber LitNumInteger x) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumWord y) <- exprIsLiteral_maybe id_unf yl - , y >= 0 - , y <= 4 -- Restrict constant-folding of shifts on Integers, somewhat - -- arbitrary. We can get huge shifts in inaccessible code - -- (#15673) - = Just (Lit (mkLitInteger (x `binop` fromIntegral y))) -match_Integer_shift_op _ _ _ _ _ = Nothing - -match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun -match_Integer_binop_Prim binop env id_unf _ [xl, yl] - | Just (LitNumber LitNumInteger x) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumInteger y) <- exprIsLiteral_maybe id_unf yl - = Just (if x `binop` y then trueValInt (roPlatform env) else falseValInt (roPlatform env)) -match_Integer_binop_Prim _ _ _ _ _ = Nothing - -match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun -match_Integer_binop_Ordering binop _ id_unf _ [xl, yl] - | Just (LitNumber LitNumInteger x) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumInteger y) <- exprIsLiteral_maybe id_unf yl - = Just $ case x `binop` y of - LT -> ltVal - EQ -> eqVal - GT -> gtVal -match_Integer_binop_Ordering _ _ _ _ _ = Nothing - -match_Integer_Int_encodeFloat :: RealFloat a - => (a -> Expr CoreBndr) - -> RuleFun -match_Integer_Int_encodeFloat mkLit _ id_unf _ [xl,yl] - | Just (LitNumber LitNumInteger x) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumInt y) <- exprIsLiteral_maybe id_unf yl - = Just (mkLit $ encodeFloat x (fromInteger y)) -match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing - ---------------------------------------------------- --- constant folding for Float/Double --- --- This turns --- rationalToFloat n d --- into a literal Float, and similarly for Doubles. --- --- it's important to not match d == 0, because that may represent a --- literal "0/0" or similar, and we can't produce a literal value for --- NaN or +-Inf -match_rationalTo :: RealFloat a - => (a -> Expr CoreBndr) - -> RuleFun -match_rationalTo mkLit _ id_unf _ [xl, yl] - | Just (LitNumber LitNumInteger x) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumInteger y) <- exprIsLiteral_maybe id_unf yl - , y /= 0 - = Just (mkLit (fromRational (x % y))) -match_rationalTo _ _ _ _ _ = Nothing - -match_passthrough :: Name -> RuleFun -match_passthrough n _ _ _ [App (Var x) y] - | idName x == n - = Just y -match_passthrough _ _ _ _ _ = Nothing - -match_smallIntegerTo :: PrimOp -> RuleFun -match_smallIntegerTo primOp _ _ _ [App (Var x) y] - | idName x == integerISDataConName - = Just $ App (Var (mkPrimOpId primOp)) y -match_smallIntegerTo _ _ _ _ _ = Nothing - - - -------------------------------------------------------- -- Note [Constant folding through nested expressions] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index c9e5aec28e..4106f4f432 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -465,11 +465,7 @@ dsExpr (ExplicitTuple _ tup_args boxity) -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make dsExpr (ExplicitSum types alt arity expr) - = dsWhenNoErrs (dsLExprNoLP expr) - (\core_expr -> mkCoreConApps (sumDataCon alt arity) - (map (Type . getRuntimeRep) types ++ - map Type types ++ - [core_expr]) ) + = dsWhenNoErrs (dsLExprNoLP expr) (mkCoreUbxSum arity alt types) dsExpr (HsPragE _ prag expr) = ds_prag_expr prag expr diff --git a/compiler/GHC/Types/Id/Make.hs-boot b/compiler/GHC/Types/Id/Make.hs-boot index 78c4b59583..40be201e61 100644 --- a/compiler/GHC/Types/Id/Make.hs-boot +++ b/compiler/GHC/Types/Id/Make.hs-boot @@ -11,5 +11,6 @@ mkDataConWorkId :: Name -> DataCon -> Id mkDictSelId :: Name -> Class -> Id mkPrimOpId :: PrimOp -> Id +voidPrimId :: Id magicDictId :: Id diff --git a/libraries/base/GHC/Enum.hs b/libraries/base/GHC/Enum.hs index 54d6c6b34a..d107c1eb12 100644 --- a/libraries/base/GHC/Enum.hs +++ b/libraries/base/GHC/Enum.hs @@ -963,8 +963,8 @@ dn_list x0 delta lim = go (x0 :: Integer) instance Enum Natural where succ n = n + 1 pred n = n - 1 - toEnum i - | i >= 0 = naturalFromIntUnsafe i + toEnum i@(I# i#) + | i >= 0 = naturalFromWord# (int2Word# i#) | otherwise = errorWithoutStackTrace "toEnum: unexpected negative Int" fromEnum (NS w) diff --git a/libraries/base/GHC/Float.hs b/libraries/base/GHC/Float.hs index eae6edb253..cb1ef6044c 100644 --- a/libraries/base/GHC/Float.hs +++ b/libraries/base/GHC/Float.hs @@ -1099,9 +1099,9 @@ fromRat'' minEx@(I# me#) mantDigs@(I# md#) n d = | isTrue# (ld'# ># (ln# +# 1#)) -> encodeFloat 0 0 -- result of shift < 0.5 | otherwise -> -- first bit of n shifted to 0.5 place case integerIsPowerOf2# n of - (# | _ #) -> encodeFloat 0 0 -- round to even - (# () | #) -> encodeFloat 1 (minEx - mantDigs) - (# () | #) -> + (# | _ #) -> encodeFloat 0 0 -- round to even + (# (# #) | #) -> encodeFloat 1 (minEx - mantDigs) + (# (# #) | #) -> let ln = I# (word2Int# (integerLog2# n)) ld = I# (word2Int# (integerLog2# d)) -- 2^(ln-ld-1) < n/d < 2^(ln-ld+1) diff --git a/libraries/base/GHC/Int.hs b/libraries/base/GHC/Int.hs index 08827e92c4..2af0856bb7 100644 --- a/libraries/base/GHC/Int.hs +++ b/libraries/base/GHC/Int.hs @@ -1124,29 +1124,29 @@ instance Ix Int64 where {-# RULES "fromIntegral/Natural->Int8" - fromIntegral = (fromIntegral :: Int -> Int8) . naturalToInt + fromIntegral = (fromIntegral :: Int -> Int8) . fromIntegral . naturalToWord "fromIntegral/Natural->Int16" - fromIntegral = (fromIntegral :: Int -> Int16) . naturalToInt + fromIntegral = (fromIntegral :: Int -> Int16) . fromIntegral . naturalToWord "fromIntegral/Natural->Int32" - fromIntegral = (fromIntegral :: Int -> Int32) . naturalToInt + fromIntegral = (fromIntegral :: Int -> Int32) . fromIntegral . naturalToWord #-} {-# RULES "fromIntegral/Int8->Natural" - fromIntegral = naturalFromIntUnsafe . (fromIntegral :: Int8 -> Int) + fromIntegral = naturalFromWord . fromIntegral . (fromIntegral :: Int8 -> Int) "fromIntegral/Int16->Natural" - fromIntegral = naturalFromIntUnsafe . (fromIntegral :: Int16 -> Int) + fromIntegral = naturalFromWord . fromIntegral . (fromIntegral :: Int16 -> Int) "fromIntegral/Int32->Natural" - fromIntegral = naturalFromIntUnsafe . (fromIntegral :: Int32 -> Int) + fromIntegral = naturalFromWord . fromIntegral . (fromIntegral :: Int32 -> Int) #-} #if WORD_SIZE_IN_BITS == 64 -- these RULES are valid for Word==Word64 & Int==Int64 {-# RULES "fromIntegral/Natural->Int64" - fromIntegral = (fromIntegral :: Int -> Int64) . naturalToInt + fromIntegral = (fromIntegral :: Int -> Int64) . fromIntegral . naturalToWord "fromIntegral/Int64->Natural" - fromIntegral = naturalFromIntUnsafe . (fromIntegral :: Int64 -> Int) + fromIntegral = naturalFromWord . fromIntegral . (fromIntegral :: Int64 -> Int) #-} #endif diff --git a/libraries/base/GHC/Natural.hs b/libraries/base/GHC/Natural.hs index 29c3a4b55e..424b2e6eef 100644 --- a/libraries/base/GHC/Natural.hs +++ b/libraries/base/GHC/Natural.hs @@ -37,12 +37,10 @@ module GHC.Natural -- * Conversions , naturalToInteger , naturalToWord - , naturalToInt - , naturalFromInteger - , wordToNatural - , intToNatural , naturalToWordMaybe + , wordToNatural , wordToNatural# + , naturalFromInteger -- * Modular arithmetic , powModNatural ) @@ -100,8 +98,8 @@ minusNatural = N.naturalSubThrow -- @since 4.8.0.0 minusNaturalMaybe :: Natural -> Natural -> Maybe Natural minusNaturalMaybe x y = case N.naturalSub x y of - (# () | #) -> Nothing - (# | n #) -> Just n + (# (# #) | #) -> Nothing + (# | n #) -> Just n -- | 'Natural' multiplication timesNatural :: Natural -> Natural -> Natural @@ -161,9 +159,6 @@ naturalToInteger = I.integerFromNatural naturalToWord :: Natural -> Word naturalToWord = N.naturalToWord -naturalToInt :: Natural -> Int -naturalToInt = N.naturalToInt - -- | @since 4.10.0.0 naturalFromInteger :: Integer -> Natural naturalFromInteger = I.integerToNatural @@ -174,17 +169,14 @@ naturalFromInteger = I.integerToNatural wordToNatural :: Word -> Natural wordToNatural = N.naturalFromWord -intToNatural :: Int -> Natural -intToNatural = N.naturalFromIntThrow - -- | Try downcasting 'Natural' to 'Word' value. -- Returns 'Nothing' if value doesn't fit in 'Word'. -- -- @since 4.8.0.0 naturalToWordMaybe :: Natural -> Maybe Word naturalToWordMaybe n = case N.naturalToWordMaybe# n of - (# w | #) -> Just (W# w) - (# | () #) -> Nothing + (# | w #) -> Just (W# w) + (# (# #) | #) -> Nothing wordToNatural# :: Word -> Natural wordToNatural# = N.naturalFromWord diff --git a/libraries/base/GHC/Num.hs b/libraries/base/GHC/Num.hs index df0c66b7bd..3d26d35a0d 100644 --- a/libraries/base/GHC/Num.hs +++ b/libraries/base/GHC/Num.hs @@ -138,13 +138,13 @@ instance Num Integer where -- -- @since 4.8.0.0 instance Num Natural where - (+) = naturalAdd - (-) = naturalSubThrow - (*) = naturalMul - negate = naturalNegate + (+) = naturalAdd + (-) = naturalSubThrow + (*) = naturalMul + negate = naturalNegate fromInteger = integerToNaturalThrow - abs = id - signum = naturalSignum + abs = id + signum = naturalSignum {-# DEPRECATED quotRemInteger "Use integerQuotRem# instead" #-} quotRemInteger :: Integer -> Integer -> (# Integer, Integer #) diff --git a/libraries/base/GHC/Real.hs b/libraries/base/GHC/Real.hs index 4d0b05a5f9..ee61e34e70 100644 --- a/libraries/base/GHC/Real.hs +++ b/libraries/base/GHC/Real.hs @@ -587,7 +587,7 @@ fromIntegral = fromInteger . toInteger {-# RULES "fromIntegral/Word->Natural" fromIntegral = naturalFromWord -"fromIntegral/Int->Natural" fromIntegral = naturalFromInt +"fromIntegral/Int->Natural" fromIntegral = naturalFromWord . fromIntegral #-} -- | general coercion to fractional types diff --git a/libraries/ghc-bignum/src/GHC/Num/BigNat.hs b/libraries/ghc-bignum/src/GHC/Num/BigNat.hs index b0408bcfa6..bd3137a116 100644 --- a/libraries/ghc-bignum/src/GHC/Num/BigNat.hs +++ b/libraries/ghc-bignum/src/GHC/Num/BigNat.hs @@ -136,13 +136,13 @@ bigNatIsTwo# ba = &&# indexWordArray# ba 0# `eqWord#` 2## -- | Indicate if the value is a power of two and which one -bigNatIsPowerOf2# :: BigNat# -> (# () | Word# #) +bigNatIsPowerOf2# :: BigNat# -> (# (# #) | Word# #) bigNatIsPowerOf2# a - | bigNatIsZero a = (# () | #) + | bigNatIsZero a = (# (# #) | #) | True = case wordIsPowerOf2# msw of - (# () | #) -> (# () | #) + (# (# #) | #) -> (# (# #) | #) (# | c #) -> case checkAllZeroes (imax -# 1#) of - 0# -> (# () | #) + 0# -> (# (# #) | #) _ -> (# | c `plusWord#` (int2Word# imax `uncheckedShiftL#` WORD_SIZE_BITS_SHIFT#) #) where @@ -227,11 +227,11 @@ bigNatToWord# a | True = bigNatIndex# a 0# -- | Convert a BigNat into a Word# if it fits -bigNatToWordMaybe# :: BigNat# -> (# Word# | () #) +bigNatToWordMaybe# :: BigNat# -> (# (# #) | Word# #) bigNatToWordMaybe# a - | bigNatIsZero a = (# 0## | #) - | isTrue# (bigNatSize# a ># 1#) = (# | () #) - | True = (# bigNatIndex# a 0# | #) + | bigNatIsZero a = (# | 0## #) + | isTrue# (bigNatSize# a ># 1#) = (# (# #) | #) + | True = (# | bigNatIndex# a 0# #) -- | Convert a BigNat into a Word bigNatToWord :: BigNat# -> Word @@ -359,8 +359,44 @@ bigNatCompare a b = -- | Predicate: a < b +bigNatLt# :: BigNat# -> BigNat# -> Bool# +bigNatLt# a b + | LT <- bigNatCompare a b = 1# + | True = 0# + +-- | Predicate: a < b bigNatLt :: BigNat# -> BigNat# -> Bool -bigNatLt a b = bigNatCompare a b == LT +bigNatLt a b = isTrue# (bigNatLt# a b) + +-- | Predicate: a <= b +bigNatLe# :: BigNat# -> BigNat# -> Bool# +bigNatLe# a b + | GT <- bigNatCompare a b = 0# + | True = 1# + +-- | Predicate: a <= b +bigNatLe :: BigNat# -> BigNat# -> Bool +bigNatLe a b = isTrue# (bigNatLe# a b) + +-- | Predicate: a > b +bigNatGt# :: BigNat# -> BigNat# -> Bool# +bigNatGt# a b + | GT <- bigNatCompare a b = 1# + | True = 0# + +-- | Predicate: a > b +bigNatGt :: BigNat# -> BigNat# -> Bool +bigNatGt a b = isTrue# (bigNatGt# a b) + +-- | Predicate: a >= b +bigNatGe# :: BigNat# -> BigNat# -> Bool# +bigNatGe# a b + | LT <- bigNatCompare a b = 0# + | True = 1# + +-- | Predicate: a >= b +bigNatGe :: BigNat# -> BigNat# -> Bool +bigNatGe a b = isTrue# (bigNatGe# a b) ------------------------------------------------- -- Addition @@ -474,10 +510,10 @@ bigNatSubWordUnsafe :: BigNat# -> Word -> BigNat# bigNatSubWordUnsafe x (W# y) = bigNatSubWordUnsafe# x y -- | Subtract a Word# from a BigNat -bigNatSubWord# :: BigNat# -> Word# -> (# () | BigNat# #) +bigNatSubWord# :: BigNat# -> Word# -> (# (# #) | BigNat# #) bigNatSubWord# a b | 0## <- b = (# | a #) - | bigNatIsZero a = (# () | #) + | bigNatIsZero a = (# (# #) | #) | True = withNewWordArrayTrimedMaybe# (bigNatSize# a) \mwa s -> inline bignat_sub_word mwa a b s @@ -498,11 +534,11 @@ bigNatSubUnsafe a b -- GHC.Num.Primitives -- | Subtract two BigNat -bigNatSub :: BigNat# -> BigNat# -> (# () | BigNat# #) +bigNatSub :: BigNat# -> BigNat# -> (# (# #) | BigNat# #) bigNatSub a b | bigNatIsZero b = (# | a #) | isTrue# (bigNatSize# a <# bigNatSize# b) - = (# () | #) + = (# (# #) | #) | True = withNewWordArrayTrimedMaybe# (bigNatSize# a) \mwa s -> @@ -1136,7 +1172,7 @@ bigNatPowModWord# b e m -- exponent @/e/@ modulo @/m/@. bigNatPowMod :: BigNat# -> BigNat# -> BigNat# -> BigNat# bigNatPowMod !b !e !m - | (# m' | #) <- bigNatToWordMaybe# m + | (# | m' #) <- bigNatToWordMaybe# m = bigNatFromWord# (bigNatPowModWord# b e m') | bigNatIsZero m = raiseDivZero_BigNat (# #) | bigNatIsOne m = bigNatFromWord# 0## diff --git a/libraries/ghc-bignum/src/GHC/Num/Integer.hs b/libraries/ghc-bignum/src/GHC/Num/Integer.hs index 2e0327127d..35afa5d15a 100644 --- a/libraries/ghc-bignum/src/GHC/Num/Integer.hs +++ b/libraries/ghc-bignum/src/GHC/Num/Integer.hs @@ -205,7 +205,7 @@ integerFromWordList :: Bool -> [Word] -> Integer integerFromWordList True ws = integerFromBigNatNeg# (bigNatFromWordList ws) integerFromWordList False ws = integerFromBigNat# (bigNatFromWordList ws) --- | Convert a Integer into a Natural +-- | Convert an Integer into a Natural -- -- Return 0 for negative Integers. integerToNaturalClamp :: Integer -> Natural @@ -216,7 +216,7 @@ integerToNaturalClamp (IS x) integerToNaturalClamp (IP x) = naturalFromBigNat# x integerToNaturalClamp (IN _) = naturalZero --- | Convert a Integer into a Natural +-- | Convert an Integer into a Natural -- -- Return absolute value integerToNatural :: Integer -> Natural @@ -225,9 +225,9 @@ integerToNatural (IS x) = naturalFromWord# (wordFromAbsInt# x) integerToNatural (IP x) = naturalFromBigNat# x integerToNatural (IN x) = naturalFromBigNat# x --- | Convert a Integer into a Natural +-- | Convert an Integer into a Natural -- --- Throw on underflow +-- Throw an Underflow exception if input is negative. integerToNaturalThrow :: Integer -> Natural {-# NOINLINE integerToNaturalThrow #-} integerToNaturalThrow (IS x) @@ -1007,11 +1007,11 @@ integerLogBase :: Integer -> Integer -> Word integerLogBase !base !i = W# (integerLogBase# base i) -- | Indicate if the value is a power of two and which one -integerIsPowerOf2# :: Integer -> (# () | Word# #) +integerIsPowerOf2# :: Integer -> (# (# #) | Word# #) integerIsPowerOf2# (IS i) - | isTrue# (i <=# 0#) = (# () | #) + | isTrue# (i <=# 0#) = (# (# #) | #) | True = wordIsPowerOf2# (int2Word# i) -integerIsPowerOf2# (IN _) = (# () | #) +integerIsPowerOf2# (IN _) = (# (# #) | #) integerIsPowerOf2# (IP w) = bigNatIsPowerOf2# w #if WORD_SIZE_IN_BITS == 32 diff --git a/libraries/ghc-bignum/src/GHC/Num/Natural.hs b/libraries/ghc-bignum/src/GHC/Num/Natural.hs index d10a76165d..55aee2d2f7 100644 --- a/libraries/ghc-bignum/src/GHC/Num/Natural.hs +++ b/libraries/ghc-bignum/src/GHC/Num/Natural.hs @@ -32,6 +32,10 @@ instance Eq Natural where instance Ord Natural where compare = naturalCompare + (>) = naturalGt + (>=) = naturalGe + (<) = naturalLt + (<=) = naturalLe -- | Check Natural invariants @@ -62,7 +66,7 @@ naturalIsOne (NS 1##) = True naturalIsOne _ = False -- | Indicate if the value is a power of two and which one -naturalIsPowerOf2# :: Natural -> (# () | Word# #) +naturalIsPowerOf2# :: Natural -> (# (# #) | Word# #) naturalIsPowerOf2# (NS w) = wordIsPowerOf2# w naturalIsPowerOf2# (NB w) = bigNatIsPowerOf2# w @@ -80,7 +84,6 @@ naturalToBigNat# (NB bn) = bn -- | Create a Natural from a Word# naturalFromWord# :: Word# -> Natural -{-# NOINLINE naturalFromWord# #-} naturalFromWord# x = NS x -- | Convert two Word# (most-significant first) into a Natural @@ -109,6 +112,7 @@ naturalToWord !n = W# (naturalToWord# n) -- | Convert a Natural into a Word# clamping to (maxBound :: Word#). naturalToWordClamp# :: Natural -> Word# +{-# NOINLINE naturalToWordClamp #-} naturalToWordClamp# (NS x) = x naturalToWordClamp# (NB _) = WORD_MAXBOUND## @@ -117,58 +121,10 @@ naturalToWordClamp :: Natural -> Word naturalToWordClamp !n = W# (naturalToWordClamp# n) -- | Try downcasting 'Natural' to 'Word' value. --- Returns '()' if value doesn't fit in 'Word'. -naturalToWordMaybe# :: Natural -> (# Word# | () #) -naturalToWordMaybe# (NS w) = (# w | #) -naturalToWordMaybe# _ = (# | () #) - --- | Create a Natural from an Int# (unsafe: silently converts negative values --- into positive ones) -naturalFromIntUnsafe# :: Int# -> Natural -naturalFromIntUnsafe# !i = NS (int2Word# i) - --- | Create a Natural from an Int (unsafe: silently converts negative values --- into positive ones) -naturalFromIntUnsafe :: Int -> Natural -naturalFromIntUnsafe (I# i) = naturalFromIntUnsafe# i - --- | Create a Natural from an Int# --- --- Throws 'Control.Exception.Underflow' when passed a negative 'Int'. -naturalFromIntThrow# :: Int# -> Natural -naturalFromIntThrow# i - | isTrue# (i <# 0#) = raiseUnderflow - | True = naturalFromIntUnsafe# i - --- | Create a Natural from an Int --- --- Throws 'Control.Exception.Underflow' when passed a negative 'Int'. -naturalFromIntThrow :: Int -> Natural -naturalFromIntThrow (I# i) = naturalFromIntThrow# i - --- | Create an Int# from a Natural (can overflow the int and give a negative --- number) -naturalToInt# :: Natural -> Int# -naturalToInt# !n = word2Int# (naturalToWord# n) - --- | Create an Int# from a Natural (can overflow the int and give a negative --- number) -naturalToInt :: Natural -> Int -naturalToInt !n = I# (naturalToInt# n) - --- | Create a Natural from an Int# --- --- Underflow exception if Int# is negative -naturalFromInt# :: Int# -> Natural -naturalFromInt# !i - | isTrue# (i >=# 0#) = NS (int2Word# i) - | True = raiseUnderflow - --- | Create a Natural from an Int --- --- Underflow exception if Int# is negative -naturalFromInt :: Int -> Natural -naturalFromInt (I# i) = naturalFromInt# i +-- Returns '(##)' if value doesn't fit in 'Word'. +naturalToWordMaybe# :: Natural -> (# (# #) | Word# #) +naturalToWordMaybe# (NS w) = (# | w #) +naturalToWordMaybe# _ = (# (# #) | #) -- | Encode (# Natural mantissa, Int# exponent #) into a Double# naturalEncodeDouble# :: Natural -> Int# -> Double# @@ -180,7 +136,7 @@ naturalEncodeDouble# (NB b) e = bigNatEncodeDouble# b e naturalToDouble# :: Natural -> Double# naturalToDouble# !n = naturalEncodeDouble# n 0# --- | Encode an Natural (mantissa) into a Float# +-- | Encode a Natural (mantissa) into a Float# naturalToFloat# :: Natural -> Float# naturalToFloat# !i = naturalEncodeFloat# i 0# @@ -193,6 +149,7 @@ naturalEncodeFloat# !m e = double2Float# (naturalEncodeDouble# m e) -- | Equality test for Natural naturalEq# :: Natural -> Natural -> Bool# +{-# NOINLINE naturalEq# #-} naturalEq# (NS x) (NS y) = x `eqWord#` y naturalEq# (NB x) (NB y) = bigNatEq# x y naturalEq# _ _ = 0# @@ -203,6 +160,7 @@ naturalEq !x !y = isTrue# (naturalEq# x y) -- | Inequality test for Natural naturalNe# :: Natural -> Natural -> Bool# +{-# NOINLINE naturalNe# #-} naturalNe# (NS x) (NS y) = x `neWord#` y naturalNe# (NB x) (NB y) = bigNatNe# x y naturalNe# _ _ = 1# @@ -211,15 +169,66 @@ naturalNe# _ _ = 1# naturalNe :: Natural -> Natural -> Bool naturalNe !x !y = isTrue# (naturalNe# x y) +-- | Greater or equal test for Natural +naturalGe# :: Natural -> Natural -> Bool# +{-# NOINLINE naturalGe# #-} +naturalGe# (NS x) (NS y) = x `geWord#` y +naturalGe# (NS _) (NB _) = 0# +naturalGe# (NB _) (NS _) = 1# +naturalGe# (NB x) (NB y) = bigNatGe# x y + +-- | Greater or equal test for Natural +naturalGe :: Natural -> Natural -> Bool +naturalGe !x !y = isTrue# (naturalGe# x y) + +-- | Lower or equal test for Natural +naturalLe# :: Natural -> Natural -> Bool# +{-# NOINLINE naturalLe# #-} +naturalLe# (NS x) (NS y) = x `leWord#` y +naturalLe# (NS _) (NB _) = 1# +naturalLe# (NB _) (NS _) = 0# +naturalLe# (NB x) (NB y) = bigNatLe# x y + +-- | Lower or equal test for Natural +naturalLe :: Natural -> Natural -> Bool +naturalLe !x !y = isTrue# (naturalLe# x y) + + +-- | Greater test for Natural +naturalGt# :: Natural -> Natural -> Bool# +{-# NOINLINE naturalGt# #-} +naturalGt# (NS x) (NS y) = x `gtWord#` y +naturalGt# (NS _) (NB _) = 0# +naturalGt# (NB _) (NS _) = 1# +naturalGt# (NB x) (NB y) = bigNatGt# x y + +-- | Greater test for Natural +naturalGt :: Natural -> Natural -> Bool +naturalGt !x !y = isTrue# (naturalGt# x y) + +-- | Lower test for Natural +naturalLt# :: Natural -> Natural -> Bool# +{-# NOINLINE naturalLt# #-} +naturalLt# (NS x) (NS y) = x `ltWord#` y +naturalLt# (NS _) (NB _) = 1# +naturalLt# (NB _) (NS _) = 0# +naturalLt# (NB x) (NB y) = bigNatLt# x y + +-- | Lower test for Natural +naturalLt :: Natural -> Natural -> Bool +naturalLt !x !y = isTrue# (naturalLt# x y) + -- | Compare two Natural naturalCompare :: Natural -> Natural -> Ordering -naturalCompare (NS x) (NS y) = compare (W# x) (W# y) +{-# NOINLINE naturalCompare #-} +naturalCompare (NS x) (NS y) = cmpW# x y naturalCompare (NB x) (NB y) = bigNatCompare x y naturalCompare (NS _) (NB _) = LT naturalCompare (NB _) (NS _) = GT -- | PopCount for Natural naturalPopCount# :: Natural -> Word# +{-# NOINLINE naturalPopCount# #-} naturalPopCount# (NS x) = popCnt# x naturalPopCount# (NB x) = bigNatPopCount# x @@ -230,6 +239,7 @@ naturalPopCount (NB x) = bigNatPopCount x -- | Right shift for Natural naturalShiftR# :: Natural -> Word# -> Natural +{-# NOINLINE naturalShiftR# #-} naturalShiftR# (NS x) n = NS (x `shiftRW#` n) naturalShiftR# (NB x) n = naturalFromBigNat# (x `bigNatShiftR#` n) @@ -239,6 +249,7 @@ naturalShiftR x (W# n) = naturalShiftR# x n -- | Left shift naturalShiftL# :: Natural -> Word# -> Natural +{-# NOINLINE naturalShiftL# #-} naturalShiftL# v@(NS x) n | 0## <- x = v | isTrue# (clz# x `geWord#` n) = NS (x `uncheckedShiftL#` word2Int# n) @@ -261,23 +272,24 @@ naturalAdd (NS x) (NS y) = (# l,c #) -> NB (bigNatFromWord2# (int2Word# c) l) -- | Sub two naturals -naturalSub :: Natural -> Natural -> (# () | Natural #) +naturalSub :: Natural -> Natural -> (# (# #) | Natural #) {-# NOINLINE naturalSub #-} -naturalSub (NS _) (NB _) = (# () | #) +naturalSub (NS _) (NB _) = (# (# #) | #) naturalSub (NB x) (NS y) = (# | naturalFromBigNat# (bigNatSubWordUnsafe# x y) #) naturalSub (NS x) (NS y) = case subWordC# x y of - (# l,0# #) -> (# | NS l #) - (# _,_ #) -> (# () | #) + (# l,0# #) -> (# | NS l #) + (# _,_ #) -> (# (# #) | #) naturalSub (NB x) (NB y) = case bigNatSub x y of - (# () | #) -> (# () | #) - (# | z #) -> (# | naturalFromBigNat# z #) + (# (# #) | #) -> (# (# #) | #) + (# | z #) -> (# | naturalFromBigNat# z #) -- | Sub two naturals -- -- Throw an Underflow exception if x < y naturalSubThrow :: Natural -> Natural -> Natural +{-# NOINLINE naturalSubThrow #-} naturalSubThrow (NS _) (NB _) = raiseUnderflow naturalSubThrow (NB x) (NS y) = naturalFromBigNat# (bigNatSubWordUnsafe# x y) naturalSubThrow (NS x) (NS y) = @@ -286,8 +298,8 @@ naturalSubThrow (NS x) (NS y) = (# _,_ #) -> raiseUnderflow naturalSubThrow (NB x) (NB y) = case bigNatSub x y of - (# () | #) -> raiseUnderflow - (# | z #) -> naturalFromBigNat# z + (# (# #) | #) -> raiseUnderflow + (# | z #) -> naturalFromBigNat# z -- | Sub two naturals -- @@ -300,8 +312,8 @@ naturalSubUnsafe (NS _) (NB _) = naturalZero naturalSubUnsafe (NB x) (NS y) = naturalFromBigNat# (bigNatSubWordUnsafe# x y) naturalSubUnsafe (NB x) (NB y) = case bigNatSub x y of - (# () | #) -> naturalZero - (# | z #) -> naturalFromBigNat# z + (# (# #) | #) -> naturalZero + (# | z #) -> naturalFromBigNat# z -- | Multiplication naturalMul :: Natural -> Natural -> Natural @@ -327,6 +339,7 @@ naturalSqr !a = naturalMul a a -- | Signum for Natural naturalSignum :: Natural -> Natural +{-# NOINLINE naturalSignum #-} naturalSignum (NS 0##) = NS 0## naturalSignum _ = NS 1## @@ -380,30 +393,35 @@ naturalRem (NB n) (NB d) = case bigNatRem n d of r -> naturalFromBigNat# r naturalAnd :: Natural -> Natural -> Natural +{-# NOINLINE naturalAnd #-} naturalAnd (NS n) (NS m) = NS (n `and#` m) naturalAnd (NS n) (NB m) = NS (n `and#` bigNatToWord# m) naturalAnd (NB n) (NS m) = NS (bigNatToWord# n `and#` m) naturalAnd (NB n) (NB m) = naturalFromBigNat# (bigNatAnd n m) naturalAndNot :: Natural -> Natural -> Natural +{-# NOINLINE naturalAndNot #-} naturalAndNot (NS n) (NS m) = NS (n `and#` not# m) naturalAndNot (NS n) (NB m) = NS (n `and#` not# (bigNatToWord# m)) naturalAndNot (NB n) (NS m) = NS (bigNatToWord# n `and#` not# m) naturalAndNot (NB n) (NB m) = naturalFromBigNat# (bigNatAndNot n m) naturalOr :: Natural -> Natural -> Natural +{-# NOINLINE naturalOr #-} naturalOr (NS n) (NS m) = NS (n `or#` m) naturalOr (NS n) (NB m) = NB (bigNatOrWord# m n) naturalOr (NB n) (NS m) = NB (bigNatOrWord# n m) naturalOr (NB n) (NB m) = NB (bigNatOr n m) naturalXor :: Natural -> Natural -> Natural +{-# NOINLINE naturalXor #-} naturalXor (NS n) (NS m) = NS (n `xor#` m) naturalXor (NS n) (NB m) = NB (bigNatXorWord# m n) naturalXor (NB n) (NS m) = NB (bigNatXorWord# n m) naturalXor (NB n) (NB m) = naturalFromBigNat# (bigNatXor n m) naturalTestBit# :: Natural -> Word# -> Bool# +{-# NOINLINE naturalTestBit# #-} naturalTestBit# (NS w) i = (i `ltWord#` WORD_SIZE_IN_BITS##) &&# ((w `and#` (1## `uncheckedShiftL#` word2Int# i)) `neWord#` 0##) naturalTestBit# (NB bn) i = bigNatTestBit# bn i @@ -412,6 +430,7 @@ naturalTestBit :: Natural -> Word -> Bool naturalTestBit !n (W# i) = isTrue# (naturalTestBit# n i) naturalBit# :: Word# -> Natural +{-# NOINLINE naturalBit# #-} naturalBit# i | isTrue# (i `ltWord#` WORD_SIZE_IN_BITS##) = NS (1## `uncheckedShiftL#` word2Int# i) | True = NB (bigNatBit# i) @@ -421,6 +440,7 @@ naturalBit (W# i) = naturalBit# i -- | Compute greatest common divisor. naturalGcd :: Natural -> Natural -> Natural +{-# NOINLINE naturalGcd #-} naturalGcd (NS 0##) !y = y naturalGcd x (NS 0##) = x naturalGcd (NS 1##) _ = NS 1## @@ -432,6 +452,7 @@ naturalGcd (NS x) (NS y) = NS (gcdWord# x y) -- | Compute least common multiple. naturalLcm :: Natural -> Natural -> Natural +{-# NOINLINE naturalLcm #-} naturalLcm (NS 0##) !_ = NS 0## naturalLcm _ (NS 0##) = NS 0## naturalLcm (NS 1##) y = y @@ -443,6 +464,7 @@ naturalLcm (NB a ) (NB b ) = naturalFromBigNat# (bigNatLcm a b) -- | Base 2 logarithm naturalLog2# :: Natural -> Word# +{-# NOINLINE naturalLog2# #-} naturalLog2# (NS w) = wordLog2# w naturalLog2# (NB b) = bigNatLog2# b @@ -452,6 +474,7 @@ naturalLog2 !n = W# (naturalLog2# n) -- | Logarithm for an arbitrary base naturalLogBaseWord# :: Word# -> Natural -> Word# +{-# NOINLINE naturalLogBaseWord# #-} naturalLogBaseWord# base (NS a) = wordLogBase# base a naturalLogBaseWord# base (NB a) = bigNatLogBaseWord# base a @@ -461,6 +484,7 @@ naturalLogBaseWord (W# base) !a = W# (naturalLogBaseWord# base a) -- | Logarithm for an arbitrary base naturalLogBase# :: Natural -> Natural -> Word# +{-# NOINLINE naturalLogBase# #-} naturalLogBase# (NS base) !a = naturalLogBaseWord# base a naturalLogBase# (NB _ ) (NS _) = 0## naturalLogBase# (NB base) (NB a) = bigNatLogBase# base a @@ -472,6 +496,7 @@ naturalLogBase !base !a = W# (naturalLogBase# base a) -- | \"@'naturalPowMod' /b/ /e/ /m/@\" computes base @/b/@ raised to -- exponent @/e/@ modulo @/m/@. naturalPowMod :: Natural -> Natural -> Natural -> Natural +{-# NOINLINE naturalPowMod #-} naturalPowMod !_ !_ (NS 0##) = raiseDivZero naturalPowMod _ _ (NS 1##) = NS 0## naturalPowMod _ (NS 0##) _ = NS 1## @@ -491,6 +516,7 @@ naturalPowMod b e (NB m) = naturalFromBigNat# -- -- `base` must be > 1 naturalSizeInBase# :: Word# -> Natural -> Word# +{-# NOINLINE naturalSizeInBase# #-} naturalSizeInBase# base (NS w) = wordSizeInBase# base w naturalSizeInBase# base (NB n) = bigNatSizeInBase# base n @@ -501,6 +527,7 @@ naturalSizeInBase# base (NB n) = bigNatSizeInBase# base n -- byte first (big-endian) if @1#@ or least significant byte first -- (little-endian) if @0#@. naturalToAddr# :: Natural -> Addr# -> Bool# -> State# s -> (# State# s, Word# #) +{-# NOINLINE naturalToAddr# #-} naturalToAddr# (NS i) = wordToAddr# i naturalToAddr# (NB n) = bigNatToAddr# n @@ -525,6 +552,7 @@ naturalToAddr a addr e = IO \s -> case naturalToAddr# a addr e s of -- -- Null higher limbs are automatically trimed. naturalFromAddr# :: Word# -> Addr# -> Bool# -> State# s -> (# State# s, Natural #) +{-# NOINLINE naturalFromAddr# #-} naturalFromAddr# sz addr e s = case bigNatFromAddr# sz addr e s of (# s', n #) -> (# s', naturalFromBigNat# n #) @@ -549,6 +577,7 @@ naturalFromAddr sz addr e = IO (naturalFromAddr# sz addr e) -- byte first (big-endian) if @1#@ or least significant byte first -- (little-endian) if @0#@. naturalToMutableByteArray# :: Natural -> MutableByteArray# s -> Word# -> Bool# -> State# s -> (# State# s, Word# #) +{-# NOINLINE naturalToMutableByteArray# #-} naturalToMutableByteArray# (NS w) = wordToMutableByteArray# w naturalToMutableByteArray# (NB a) = bigNatToMutableByteArray# a @@ -562,5 +591,6 @@ naturalToMutableByteArray# (NB a) = bigNatToMutableByteArray# a -- -- Null higher limbs are automatically trimed. naturalFromByteArray# :: Word# -> ByteArray# -> Word# -> Bool# -> State# s -> (# State# s, Natural #) +{-# NOINLINE naturalFromByteArray# #-} naturalFromByteArray# sz ba off e s = case bigNatFromByteArray# sz ba off e s of (# s', a #) -> (# s', naturalFromBigNat# a #) diff --git a/libraries/ghc-bignum/src/GHC/Num/Primitives.hs b/libraries/ghc-bignum/src/GHC/Num/Primitives.hs index 033262b229..589600e047 100644 --- a/libraries/ghc-bignum/src/GHC/Num/Primitives.hs +++ b/libraries/ghc-bignum/src/GHC/Num/Primitives.hs @@ -271,9 +271,9 @@ wordSizeInBase# _ 0## = 0## wordSizeInBase# base w = 1## `plusWord#` wordLogBase# base w -- | Indicate if the value is a power of two and which one -wordIsPowerOf2# :: Word# -> (# () | Word# #) +wordIsPowerOf2# :: Word# -> (# (# #) | Word# #) wordIsPowerOf2# w - | isTrue# (popCnt# w `neWord#` 1##) = (# () | #) + | isTrue# (popCnt# w `neWord#` 1##) = (# (# #) | #) | True = (# | ctz# w #) -- | Reverse bytes in a Word# diff --git a/libraries/ghc-bignum/src/GHC/Num/WordArray.hs b/libraries/ghc-bignum/src/GHC/Num/WordArray.hs index dffb7e5797..d4ada9bb3b 100644 --- a/libraries/ghc-bignum/src/GHC/Num/WordArray.hs +++ b/libraries/ghc-bignum/src/GHC/Num/WordArray.hs @@ -108,13 +108,13 @@ withNewWordArray2Trimed# sz1 sz2 act = withNewWordArray2# sz1 sz2 \mwa1 mwa2 s - withNewWordArrayTrimedMaybe# :: Int# -- ^ Size in Word -> (MutableWordArray# RealWorld -> State# RealWorld -> (# State# RealWorld, Bool# #)) - -> (# () | WordArray# #) + -> (# (# #) | WordArray# #) withNewWordArrayTrimedMaybe# sz act = case runRW# io of (# _, a #) -> a where io s = case newWordArray# sz s of (# s, mwa #) -> case act mwa s of - (# s, 0# #) -> (# s, (# () | #) #) + (# s, 0# #) -> (# s, (# (# #) | #) #) (# s, _ #) -> case mwaTrimZeroes# mwa s of s -> case unsafeFreezeByteArray# mwa s of (# s, ba #) -> (# s, (# | ba #) #) diff --git a/libraries/integer-gmp/src/GHC/Integer/GMP/Internals.hs b/libraries/integer-gmp/src/GHC/Integer/GMP/Internals.hs index 2fcb0750ed..7fa06bf52c 100644 --- a/libraries/integer-gmp/src/GHC/Integer/GMP/Internals.hs +++ b/libraries/integer-gmp/src/GHC/Integer/GMP/Internals.hs @@ -244,14 +244,14 @@ plusBigNatWord (BN# a) w = BN# (B.bigNatAddWord# a w) {-# DEPRECATED minusBigNat "Use bigNatSub instead" #-} minusBigNat :: BigNat -> BigNat -> BigNat minusBigNat (BN# a) (BN# b) = case B.bigNatSub a b of - (# () | #) -> throw Underflow - (# | r #) -> BN# r + (# (# #) | #) -> throw Underflow + (# | r #) -> BN# r {-# DEPRECATED minusBigNatWord "Use bigNatSubWord# instead" #-} minusBigNatWord :: BigNat -> GmpLimb# -> BigNat minusBigNatWord (BN# a) b = case B.bigNatSubWord# a b of - (# () | #) -> throw Underflow - (# | r #) -> BN# r + (# (# #) | #) -> throw Underflow + (# | r #) -> BN# r {-# DEPRECATED timesBigNat "Use bigNatMul instead" #-} diff --git a/testsuite/tests/lib/integer/Makefile b/testsuite/tests/lib/integer/Makefile index aa2704ab6d..4292a1b970 100644 --- a/testsuite/tests/lib/integer/Makefile +++ b/testsuite/tests/lib/integer/Makefile @@ -2,14 +2,18 @@ TOP=../../.. include $(TOP)/mk/boilerplate.mk include $(TOP)/mk/test.mk -CHECK = grep -q -- '$1' integerConstantFolding.simpl || \ +CHECK = grep -q -- '$1' folding.simpl || \ echo "$2 didn't constant fold" +CHECK2 = grep -q -- '$1' folding.simpl || \ + grep -q -- '$2' folding.simpl || \ + echo "$3 didn't constant fold" + .PHONY: integerConstantFolding integerConstantFolding: - '$(TEST_HC)' -Wall -v0 -O --make integerConstantFolding -fforce-recomp -ddump-simpl > integerConstantFolding.simpl + '$(TEST_HC)' -Wall -v0 -O --make integerConstantFolding -fforce-recomp -ddump-simpl > folding.simpl # All the 100nnn values should be constant-folded away - ! grep -q '\<100[0-9][0-9][0-9]\>' integerConstantFolding.simpl || { echo "Unfolded values found"; grep '\<100[0-9][0-9][0-9]\>' integerConstantFolding.simpl; } + ! grep -q '\<100[0-9][0-9][0-9]\>' folding.simpl || { echo "Unfolded values found"; grep '\<100[0-9][0-9][0-9]\>' folding.simpl; } $(call CHECK,\<200007\>,plusInteger) $(call CHECK,\<683234160\>,timesInteger) $(call CHECK,-991\>,minusIntegerN) @@ -58,3 +62,43 @@ IntegerConversionRules: -grep -q integerToWord $@.simpl && echo "integerToWord present" -grep -q int2Word $@.simpl || echo "int2Word absent" +.PHONY: naturalConstantFolding +naturalConstantFolding: + '$(TEST_HC)' -Wall -v0 -O --make naturalConstantFolding -fforce-recomp -ddump-simpl > folding.simpl +# All the 100nnn values should be constant-folded away + ! grep -q '\<100[0-9][0-9][0-9]\>' folding.simpl || { echo "Unfolded values found"; grep '\<100[0-9][0-9][0-9]\>' folding.simpl; } + # Bit arithmetic + $(call CHECK,\<532\>,andNatural) + $(call CHECK,\<239055\>,xorNatural) + $(call CHECK,\<16\>,bitNatural) + $(call CHECK,\<239579\>,orNatural) + $(call CHECK,\<1601040\>,shiftLNatural) + $(call CHECK,\<6254\>,shiftRNatural) + $(call CHECK,\<6\>,popCountNatural) + # Arithmetic + $(call CHECK,\<200121\>,plusNatural) + $(call CHECK,\<683678240\>,timesNatural) + $(call CHECK,\<989\>,minusNatural) + $(call CHECK,\<0\>,negateNatural) + $(call CHECK,\<1\>,signumNaturalP) + $(call CHECK,\<0\>,signumNaturalZ) + # Quotients and remainders + $(call CHECK2,\<813\>,\<60\>,quotRemNatural) + $(call CHECK2,\<219\>,\<196\>,divModNatural) + $(call CHECK,\<641\>,quotNatural) + $(call CHECK,\<68\>,remNatural) + $(call CHECK,\<642\>,divNatural) + $(call CHECK,\<90\>,modNatural) + $(call CHECK,\<50024\>,gcdNatural) + $(call CHECK,\<1001100300\>,lcmNatural) + # Conversions + $(call CHECK,\<200109\>,naturalFromInteger) + $(call CHECK,\<200113\>,naturalToInteger) + $(call CHECK,\<200145\>,wordToNatural) + $(call CHECK,\<200149\>,naturalToWord) + $(call CHECK,\<200153\>,intToNatural) + $(call CHECK,\<200157\>,naturalToInt) + $(call CHECK,\<200189.0\>,doubleFromNatural) + $(call CHECK,\<200193.0\>,floatFromNatural) + # Ordering and Equality + ./naturalConstantFolding diff --git a/testsuite/tests/lib/integer/all.T b/testsuite/tests/lib/integer/all.T index f279be2f81..c132ca24dd 100644 --- a/testsuite/tests/lib/integer/all.T +++ b/testsuite/tests/lib/integer/all.T @@ -3,6 +3,7 @@ test('integerBits', normal, compile_and_run, ['']) test('integerConversions', normal, compile_and_run, ['']) test('plusMinusInteger', [omit_ways(['ghci'])], compile_and_run, ['']) test('integerConstantFolding', normal, makefile_test, ['integerConstantFolding']) +test('naturalConstantFolding', normal, makefile_test, ['naturalConstantFolding']) test('fromToInteger', [], makefile_test, ['fromToInteger']) test('IntegerConversionRules', [], makefile_test, ['IntegerConversionRules']) test('gcdInteger', normal, compile_and_run, ['']) diff --git a/testsuite/tests/lib/integer/naturalConstantFolding.hs b/testsuite/tests/lib/integer/naturalConstantFolding.hs new file mode 100644 index 0000000000..9469d44bf6 --- /dev/null +++ b/testsuite/tests/lib/integer/naturalConstantFolding.hs @@ -0,0 +1,172 @@ +module Main (main) where + +import Data.Bits +import Numeric.Natural (Natural) + +main :: IO () +main = do + p "andNatural" andNatural + p "bitNatural" bitNatural + p "minusNatural" minusNatural + p "naturalFromInteger" naturalFromInteger + p "naturalToInteger" naturalToInteger + p "negateNatural" negateNatural + p "orNatural" orNatural + p "plusNatural" plusNatural + p "popCountNatural" popCountNatural + p "divModNatural" divModNatural + p "divNatural" divNatural + p "modNatural" modNatural + p "quotNatural" quotNatural + p "quotRemNatural" quotRemNatural + p "remNatural" remNatural + p "gcdNatural" gcdNatural + p "lcmNatural" lcmNatural + p "shiftLNatural" shiftLNatural + p "shiftRNatural" shiftRNatural + p "signumNaturalP" signumNaturalP + p "signumNaturalZ" signumNaturalZ + p "testBitNaturalT" testBitNaturalT + p "testBitNaturalF" testBitNaturalF + p "timesNatural" timesNatural + p "wordToNatural" wordToNatural + p "naturalToWord" naturalToWord + p "intToNatural" intToNatural + p "naturalToInt" naturalToInt + p "doubleFromNatural" doubleFromNatural + p "floatFromNatural" floatFromNatural + p "xorNatural" xorNatural + p "eqNatural" eqNatural + p "neqNatural" neqNatural + p "leNatural" leNatural + p "ltNatural" ltNatural + p "geNatural" geNatural + p "gtNatural" gtNatural + p "compareNatural" compareNatural + + where p :: Show a => String -> a -> IO () + p str x = putStrLn (str ++ ": " ++ show x) + +-- Bit arithmetic +andNatural :: Natural +andNatural = 100052 .&. 140053 + +xorNatural :: Natural +xorNatural = 100071 `xor` 140072 + +bitNatural :: Natural +bitNatural = bit 4 + +orNatural :: Natural +orNatural = 100058 .|. 140059 + +shiftLNatural :: Natural +shiftLNatural = 100065 `shiftL` 4 + +shiftRNatural :: Natural +shiftRNatural = 100066 `shiftR` 4 + +popCountNatural :: Int +popCountNatural = popCount (100098 :: Natural) + +testBitNaturalT :: Bool +testBitNaturalT = testBit (100068 :: Natural) 2 + +testBitNaturalF :: Bool +testBitNaturalF = testBit (100069 :: Natural) 1 +----------------------------------------------- + +-- Arithmetic +plusNatural :: Natural +plusNatural = 100060 + 100061 + +timesNatural :: Natural +timesNatural = 100070 * 6832 + +minusNatural :: Natural +minusNatural = 100999 - 100010 + +negateNatural :: Natural +negateNatural = negate 0 + +signumNaturalP :: Natural +signumNaturalP = signum 100067 + +signumNaturalZ :: Natural +signumNaturalZ = signum 0 +------------------------ + +-- Quotients and remainders +quotRemNatural :: (Natural, Natural) +quotRemNatural = 100063 `quotRem` 123 + +divModNatural :: (Natural, Natural) +divModNatural = 100060 `divMod` 456 + +quotNatural :: Natural +quotNatural = 100062 `quot` 156 + +remNatural :: Natural +remNatural = 100064 `rem` 156 + +divNatural :: Natural +divNatural = 100286 `div` 156 + +modNatural :: Natural +modNatural = 100086 `mod` 156 + +gcdNatural :: Natural +gcdNatural = 100048 `gcd` 150072 + +lcmNatural :: Natural +lcmNatural = 100050 `lcm` 100060 +-------------------------------- + +-- Conversions +naturalFromInteger :: Natural +naturalFromInteger = fromInteger 100054 + 100055 + +naturalToInteger :: Integer +naturalToInteger = toInteger (100056 :: Natural) + 100057 + +-- Same story as the @Integer@ case: for the conversion functions, we can't +-- just check that e.g. 100065 is in the resulting core, because it will be +-- regardless of whether the rules fire or not. So we add something to the +-- number being converted, and thus rely on the addition rule for the +-- end-result type also firing. +wordToNatural :: Natural +wordToNatural = fromIntegral (100072 :: Word) + 100073 + +naturalToWord :: Word +naturalToWord = 100075 + fromIntegral (100074 :: Natural) + +intToNatural :: Natural +intToNatural = fromIntegral (100076 :: Int) + 100077 + +naturalToInt :: Int +naturalToInt = fromIntegral (100078 :: Natural) + 100079 + +doubleFromNatural :: Double +doubleFromNatural = 100095.0 + realToFrac (100094 :: Natural) + +floatFromNatural :: Float +floatFromNatural = 100097.0 + realToFrac (100096 :: Natural) + +--------------------------------------------------- + +-- Ordering and Equality +eqNatural, neqNatural, leNatural, ltNatural, geNatural, gtNatural :: Bool +eqNatural = (100080 :: Natural) == 100081 + +neqNatural = (100082 :: Natural) /= 100083 + +leNatural = (100084 :: Natural) <= 100085 + +ltNatural = (100086 :: Natural) < 100087 + +geNatural = (100088 :: Natural) >= 100089 + +gtNatural = (100090 :: Natural) > 100091 + +compareNatural :: Ordering +compareNatural = compare (100092 :: Natural) 100093 diff --git a/testsuite/tests/lib/integer/naturalConstantFolding.stdout b/testsuite/tests/lib/integer/naturalConstantFolding.stdout new file mode 100644 index 0000000000..3a8edda426 --- /dev/null +++ b/testsuite/tests/lib/integer/naturalConstantFolding.stdout @@ -0,0 +1,38 @@ +andNatural: 532 +bitNatural: 16 +minusNatural: 989 +naturalFromInteger: 200109 +naturalToInteger: 200113 +negateNatural: 0 +orNatural: 239579 +plusNatural: 200121 +popCountNatural: 6 +divModNatural: (219,196) +divNatural: 642 +modNatural: 90 +quotNatural: 641 +quotRemNatural: (813,64) +remNatural: 68 +gcdNatural: 50024 +lcmNatural: 1001100300 +shiftLNatural: 1601040 +shiftRNatural: 6254 +signumNaturalP: 1 +signumNaturalZ: 0 +testBitNaturalT: True +testBitNaturalF: False +timesNatural: 683678240 +wordToNatural: 200145 +naturalToWord: 200149 +intToNatural: 200153 +naturalToInt: 200157 +doubleFromNatural: 200189.0 +floatFromNatural: 200193.0 +xorNatural: 239055 +eqNatural: False +neqNatural: True +leNatural: True +ltNatural: True +geNatural: False +gtNatural: False +compareNatural: LT diff --git a/testsuite/tests/simplCore/should_compile/T15445.stderr b/testsuite/tests/simplCore/should_compile/T15445.stderr index bdeef2e1d8..3421b37072 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# (BUILTIN) +Rule fired: Integer -> Int# (wrap) (BUILTIN) Rule fired: SPEC plusTwoRec (T15445a) Rule fired: SPEC $fShow[] (GHC.Show) Rule fired: Class op >> (BUILTIN) |