diff options
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) |