diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2020-02-11 09:41:44 +0100 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2020-06-17 16:22:03 -0400 |
| commit | 96aa57878fd6e6a7b92e841a0df8b5255a559c97 (patch) | |
| tree | da1dabadf29c6b681682a4577b4ca08e29bc44a5 /compiler | |
| parent | 9f96bc127d6231b5e76bbab442244eb303b08867 (diff) | |
| download | haskell-96aa57878fd6e6a7b92e841a0df8b5255a559c97.tar.gz | |
Update compiler
Thanks to ghc-bignum, the compiler can be simplified:
* Types and constructors of Integer and Natural can be wired-in. It
means that we don't have to query them from interfaces. It also means
that numeric literals don't have to carry their type with them.
* The same code is used whatever ghc-bignum backend is enabled. In
particular, conversion of bignum literals into final Core expressions
is now much more straightforward. Bignum closure inspection too.
* GHC itself doesn't depend on any integer-* package anymore
* The `integerLibrary` setting is gone.
Diffstat (limited to 'compiler')
36 files changed, 939 insertions, 945 deletions
diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs index 3494c4a2d2..21196c415d 100644 --- a/compiler/GHC/Builtin/Names.hs +++ b/compiler/GHC/Builtin/Names.hs @@ -374,31 +374,57 @@ basicKnownKeyNames printName, fstName, sndName, dollarName, - -- Integer - integerTyConName, mkIntegerName, - integerToWord64Name, integerToInt64Name, - word64ToIntegerName, int64ToIntegerName, - plusIntegerName, timesIntegerName, smallIntegerName, - wordToIntegerName, - integerToWordName, integerToIntName, minusIntegerName, - negateIntegerName, eqIntegerPrimName, neqIntegerPrimName, - absIntegerName, signumIntegerName, - leIntegerPrimName, gtIntegerPrimName, ltIntegerPrimName, geIntegerPrimName, - compareIntegerName, quotRemIntegerName, divModIntegerName, - quotIntegerName, remIntegerName, divIntegerName, modIntegerName, - floatFromIntegerName, doubleFromIntegerName, - encodeFloatIntegerName, encodeDoubleIntegerName, - decodeDoubleIntegerName, - gcdIntegerName, lcmIntegerName, - andIntegerName, orIntegerName, xorIntegerName, complementIntegerName, - shiftLIntegerName, shiftRIntegerName, bitIntegerName, - integerSDataConName,naturalSDataConName, - - -- Natural - naturalTyConName, - naturalFromIntegerName, naturalToIntegerName, - plusNaturalName, minusNaturalName, timesNaturalName, mkNaturalName, - wordToNaturalName, + -- ghc-bignum + integerFromNaturalName, + integerToNaturalClampName, + integerToWordName, + integerToIntName, + integerToWord64Name, + integerToInt64Name, + integerFromWordName, + integerFromWord64Name, + integerFromInt64Name, + integerAddName, + integerMulName, + integerSubName, + integerNegateName, + integerEqPrimName, + integerNePrimName, + integerLePrimName, + integerGtPrimName, + integerLtPrimName, + integerGePrimName, + integerAbsName, + integerSignumName, + integerCompareName, + integerQuotName, + integerRemName, + integerDivName, + integerModName, + integerDivModName, + integerQuotRemName, + integerToFloatName, + integerToDoubleName, + integerEncodeFloatName, + integerEncodeDoubleName, + integerDecodeDoubleName, + integerGcdName, + integerLcmName, + integerAndName, + integerOrName, + integerXorName, + integerComplementName, + integerBitName, + integerShiftLName, + integerShiftRName, + naturalToWordName, + naturalAddName, + naturalSubName, + naturalMulName, + naturalQuotName, + naturalRemName, + naturalQuotRemName, + bignatFromWordListName, -- Float/Double rationalToFloatName, @@ -510,7 +536,8 @@ pRELUDE = mkBaseModule_ pRELUDE_NAME gHC_PRIM, gHC_PRIM_PANIC, gHC_TYPES, gHC_GENERICS, gHC_MAGIC, gHC_CLASSES, gHC_PRIMOPWRAPPERS, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_GHCI_HELPERS, gHC_CSTRING, - gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE, gHC_INTEGER_TYPE, gHC_NATURAL, + gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE, + gHC_NUM_INTEGER, gHC_NUM_NATURAL, gHC_NUM_BIGNAT, gHC_LIST, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_LIST, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, gHC_CONC, gHC_IO, gHC_IO_Exception, @@ -538,8 +565,9 @@ gHC_SHOW = mkBaseModule (fsLit "GHC.Show") gHC_READ = mkBaseModule (fsLit "GHC.Read") gHC_NUM = mkBaseModule (fsLit "GHC.Num") gHC_MAYBE = mkBaseModule (fsLit "GHC.Maybe") -gHC_INTEGER_TYPE= mkIntegerModule (fsLit "GHC.Integer.Type") -gHC_NATURAL = mkBaseModule (fsLit "GHC.Natural") +gHC_NUM_INTEGER = mkBignumModule (fsLit "GHC.Num.Integer") +gHC_NUM_NATURAL = mkBignumModule (fsLit "GHC.Num.Natural") +gHC_NUM_BIGNAT = mkBignumModule (fsLit "GHC.Num.BigNat") gHC_LIST = mkBaseModule (fsLit "GHC.List") gHC_TUPLE = mkPrimModule (fsLit "GHC.Tuple") dATA_TUPLE = mkBaseModule (fsLit "Data.Tuple") @@ -627,8 +655,8 @@ dATA_ARRAY_PARALLEL_PRIM_NAME = mkModuleNameFS (fsLit "Data.Array.Parallel.Prim" mkPrimModule :: FastString -> Module mkPrimModule m = mkModule primUnit (mkModuleNameFS m) -mkIntegerModule :: FastString -> Module -mkIntegerModule m = mkModule integerUnit (mkModuleNameFS m) +mkBignumModule :: FastString -> Module +mkBignumModule m = mkModule bignumUnit (mkModuleNameFS m) mkBaseModule :: FastString -> Module mkBaseModule m = mkBaseModule_ (mkModuleNameFS m) @@ -707,10 +735,10 @@ enumFromTo_RDR = nameRdrName enumFromToName enumFromThen_RDR = nameRdrName enumFromThenName enumFromThenTo_RDR = nameRdrName enumFromThenToName -ratioDataCon_RDR, plusInteger_RDR, timesInteger_RDR :: RdrName +ratioDataCon_RDR, integerAdd_RDR, integerMul_RDR :: RdrName ratioDataCon_RDR = nameRdrName ratioDataConName -plusInteger_RDR = nameRdrName plusIntegerName -timesInteger_RDR = nameRdrName timesIntegerName +integerAdd_RDR = nameRdrName integerAddName +integerMul_RDR = nameRdrName integerMulName ioDataCon_RDR :: RdrName ioDataCon_RDR = nameRdrName ioDataConName @@ -1118,84 +1146,125 @@ fromIntegerName = varQual gHC_NUM (fsLit "fromInteger") fromIntegerClassOpKey minusName = varQual gHC_NUM (fsLit "-") minusClassOpKey negateName = varQual gHC_NUM (fsLit "negate") negateClassOpKey -integerTyConName, mkIntegerName, integerSDataConName, - integerToWord64Name, integerToInt64Name, - word64ToIntegerName, int64ToIntegerName, - plusIntegerName, timesIntegerName, smallIntegerName, - wordToIntegerName, - integerToWordName, integerToIntName, minusIntegerName, - negateIntegerName, eqIntegerPrimName, neqIntegerPrimName, - absIntegerName, signumIntegerName, - leIntegerPrimName, gtIntegerPrimName, ltIntegerPrimName, geIntegerPrimName, - compareIntegerName, quotRemIntegerName, divModIntegerName, - quotIntegerName, remIntegerName, divIntegerName, modIntegerName, - floatFromIntegerName, doubleFromIntegerName, - encodeFloatIntegerName, encodeDoubleIntegerName, - decodeDoubleIntegerName, - gcdIntegerName, lcmIntegerName, - andIntegerName, orIntegerName, xorIntegerName, complementIntegerName, - shiftLIntegerName, shiftRIntegerName, bitIntegerName :: Name -integerTyConName = tcQual gHC_INTEGER_TYPE (fsLit "Integer") integerTyConKey -integerSDataConName = dcQual gHC_INTEGER_TYPE (fsLit "S#") integerSDataConKey -mkIntegerName = varQual gHC_INTEGER_TYPE (fsLit "mkInteger") mkIntegerIdKey -integerToWord64Name = varQual gHC_INTEGER_TYPE (fsLit "integerToWord64") integerToWord64IdKey -integerToInt64Name = varQual gHC_INTEGER_TYPE (fsLit "integerToInt64") integerToInt64IdKey -word64ToIntegerName = varQual gHC_INTEGER_TYPE (fsLit "word64ToInteger") word64ToIntegerIdKey -int64ToIntegerName = varQual gHC_INTEGER_TYPE (fsLit "int64ToInteger") int64ToIntegerIdKey -plusIntegerName = varQual gHC_INTEGER_TYPE (fsLit "plusInteger") plusIntegerIdKey -timesIntegerName = varQual gHC_INTEGER_TYPE (fsLit "timesInteger") timesIntegerIdKey -smallIntegerName = varQual gHC_INTEGER_TYPE (fsLit "smallInteger") smallIntegerIdKey -wordToIntegerName = varQual gHC_INTEGER_TYPE (fsLit "wordToInteger") wordToIntegerIdKey -integerToWordName = varQual gHC_INTEGER_TYPE (fsLit "integerToWord") integerToWordIdKey -integerToIntName = varQual gHC_INTEGER_TYPE (fsLit "integerToInt") integerToIntIdKey -minusIntegerName = varQual gHC_INTEGER_TYPE (fsLit "minusInteger") minusIntegerIdKey -negateIntegerName = varQual gHC_INTEGER_TYPE (fsLit "negateInteger") negateIntegerIdKey -eqIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "eqInteger#") eqIntegerPrimIdKey -neqIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "neqInteger#") neqIntegerPrimIdKey -absIntegerName = varQual gHC_INTEGER_TYPE (fsLit "absInteger") absIntegerIdKey -signumIntegerName = varQual gHC_INTEGER_TYPE (fsLit "signumInteger") signumIntegerIdKey -leIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "leInteger#") leIntegerPrimIdKey -gtIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "gtInteger#") gtIntegerPrimIdKey -ltIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "ltInteger#") ltIntegerPrimIdKey -geIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "geInteger#") geIntegerPrimIdKey -compareIntegerName = varQual gHC_INTEGER_TYPE (fsLit "compareInteger") compareIntegerIdKey -quotRemIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotRemInteger") quotRemIntegerIdKey -divModIntegerName = varQual gHC_INTEGER_TYPE (fsLit "divModInteger") divModIntegerIdKey -quotIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotInteger") quotIntegerIdKey -remIntegerName = varQual gHC_INTEGER_TYPE (fsLit "remInteger") remIntegerIdKey -divIntegerName = varQual gHC_INTEGER_TYPE (fsLit "divInteger") divIntegerIdKey -modIntegerName = varQual gHC_INTEGER_TYPE (fsLit "modInteger") modIntegerIdKey -floatFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "floatFromInteger") floatFromIntegerIdKey -doubleFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "doubleFromInteger") doubleFromIntegerIdKey -encodeFloatIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeFloatInteger") encodeFloatIntegerIdKey -encodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeDoubleInteger") encodeDoubleIntegerIdKey -decodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "decodeDoubleInteger") decodeDoubleIntegerIdKey -gcdIntegerName = varQual gHC_INTEGER_TYPE (fsLit "gcdInteger") gcdIntegerIdKey -lcmIntegerName = varQual gHC_INTEGER_TYPE (fsLit "lcmInteger") lcmIntegerIdKey -andIntegerName = varQual gHC_INTEGER_TYPE (fsLit "andInteger") andIntegerIdKey -orIntegerName = varQual gHC_INTEGER_TYPE (fsLit "orInteger") orIntegerIdKey -xorIntegerName = varQual gHC_INTEGER_TYPE (fsLit "xorInteger") xorIntegerIdKey -complementIntegerName = varQual gHC_INTEGER_TYPE (fsLit "complementInteger") complementIntegerIdKey -shiftLIntegerName = varQual gHC_INTEGER_TYPE (fsLit "shiftLInteger") shiftLIntegerIdKey -shiftRIntegerName = varQual gHC_INTEGER_TYPE (fsLit "shiftRInteger") shiftRIntegerIdKey -bitIntegerName = varQual gHC_INTEGER_TYPE (fsLit "bitInteger") bitIntegerIdKey - --- GHC.Natural types -naturalTyConName, naturalSDataConName :: Name -naturalTyConName = tcQual gHC_NATURAL (fsLit "Natural") naturalTyConKey -naturalSDataConName = dcQual gHC_NATURAL (fsLit "NatS#") naturalSDataConKey - -naturalFromIntegerName :: Name -naturalFromIntegerName = varQual gHC_NATURAL (fsLit "naturalFromInteger") naturalFromIntegerIdKey - -naturalToIntegerName, plusNaturalName, minusNaturalName, timesNaturalName, - mkNaturalName, wordToNaturalName :: Name -naturalToIntegerName = varQual gHC_NATURAL (fsLit "naturalToInteger") naturalToIntegerIdKey -plusNaturalName = varQual gHC_NATURAL (fsLit "plusNatural") plusNaturalIdKey -minusNaturalName = varQual gHC_NATURAL (fsLit "minusNatural") minusNaturalIdKey -timesNaturalName = varQual gHC_NATURAL (fsLit "timesNatural") timesNaturalIdKey -mkNaturalName = varQual gHC_NATURAL (fsLit "mkNatural") mkNaturalIdKey -wordToNaturalName = varQual gHC_NATURAL (fsLit "wordToNatural#") wordToNaturalIdKey +--------------------------------- +-- ghc-bignum +--------------------------------- +integerFromNaturalName + , integerToNaturalClampName + , integerToWordName + , integerToIntName + , integerToWord64Name + , integerToInt64Name + , integerFromWordName + , integerFromWord64Name + , integerFromInt64Name + , integerAddName + , integerMulName + , integerSubName + , integerNegateName + , integerEqPrimName + , integerNePrimName + , integerLePrimName + , integerGtPrimName + , integerLtPrimName + , integerGePrimName + , integerAbsName + , integerSignumName + , integerCompareName + , integerQuotName + , integerRemName + , integerDivName + , integerModName + , integerDivModName + , integerQuotRemName + , integerToFloatName + , integerToDoubleName + , integerEncodeFloatName + , integerEncodeDoubleName + , integerDecodeDoubleName + , integerGcdName + , integerLcmName + , integerAndName + , integerOrName + , integerXorName + , integerComplementName + , integerBitName + , integerShiftLName + , integerShiftRName + , naturalToWordName + , naturalAddName + , naturalSubName + , naturalMulName + , naturalQuotName + , naturalRemName + , naturalQuotRemName + , bignatFromWordListName + :: Name + +bnbVarQual, bnnVarQual, bniVarQual :: String -> Unique -> Name +bnbVarQual str key = varQual gHC_NUM_BIGNAT (fsLit str) key +bnnVarQual str key = varQual gHC_NUM_NATURAL (fsLit str) key +bniVarQual str key = varQual gHC_NUM_INTEGER (fsLit str) key + +-- Types and DataCons +bignatFromWordListName = bnbVarQual "bigNatFromWordList#" bignatFromWordListIdKey + +naturalToWordName = bnnVarQual "naturalToWord#" naturalToWordIdKey +naturalAddName = bnnVarQual "naturalAdd" naturalAddIdKey +naturalSubName = bnnVarQual "naturalSubUnsafe" naturalSubIdKey +naturalMulName = bnnVarQual "naturalMul" naturalMulIdKey +naturalQuotName = bnnVarQual "naturalQuot" naturalQuotIdKey +naturalRemName = bnnVarQual "naturalRem" naturalRemIdKey +naturalQuotRemName = bnnVarQual "naturalQuotRem" naturalQuotRemIdKey + +integerFromNaturalName = bniVarQual "integerFromNatural" integerFromNaturalIdKey +integerToNaturalClampName = bniVarQual "integerToNaturalClamp" integerToNaturalClampIdKey +integerToWordName = bniVarQual "integerToWord#" integerToWordIdKey +integerToIntName = bniVarQual "integerToInt#" integerToIntIdKey +integerToWord64Name = bniVarQual "integerToWord64#" integerToWord64IdKey +integerToInt64Name = bniVarQual "integerToInt64#" integerToInt64IdKey +integerFromWordName = bniVarQual "integerFromWord#" integerFromWordIdKey +integerFromWord64Name = bniVarQual "integerFromWord64#" integerFromWord64IdKey +integerFromInt64Name = bniVarQual "integerFromInt64#" integerFromInt64IdKey +integerAddName = bniVarQual "integerAdd" integerAddIdKey +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 +integerAbsName = bniVarQual "integerAbs" integerAbsIdKey +integerSignumName = bniVarQual "integerSignum" integerSignumIdKey +integerCompareName = bniVarQual "integerCompare" integerCompareIdKey +integerQuotName = bniVarQual "integerQuot" integerQuotIdKey +integerRemName = bniVarQual "integerRem" integerRemIdKey +integerDivName = bniVarQual "integerDiv" integerDivIdKey +integerModName = bniVarQual "integerMod" integerModIdKey +integerDivModName = bniVarQual "integerDivMod#" integerDivModIdKey +integerQuotRemName = bniVarQual "integerQuotRem#" integerQuotRemIdKey +integerToFloatName = bniVarQual "integerToFloat#" integerToFloatIdKey +integerToDoubleName = bniVarQual "integerToDouble#" integerToDoubleIdKey +integerEncodeFloatName = bniVarQual "integerEncodeFloat#" integerEncodeFloatIdKey +integerEncodeDoubleName = bniVarQual "integerEncodeDouble#" integerEncodeDoubleIdKey +integerDecodeDoubleName = bniVarQual "integerDecodeDouble#" integerDecodeDoubleIdKey +integerGcdName = bniVarQual "integerGcd" integerGcdIdKey +integerLcmName = bniVarQual "integerLcm" integerLcmIdKey +integerAndName = bniVarQual "integerAnd" integerAndIdKey +integerOrName = bniVarQual "integerOr" integerOrIdKey +integerXorName = bniVarQual "integerXor" integerXorIdKey +integerComplementName = bniVarQual "integerComplement" integerComplementIdKey +integerBitName = bniVarQual "integerBit#" integerBitIdKey +integerShiftLName = bniVarQual "integerShiftL#" integerShiftLIdKey +integerShiftRName = bniVarQual "integerShiftR#" integerShiftRIdKey + + + +--------------------------------- +-- End of ghc-bignum +--------------------------------- -- GHC.Real types and classes rationalTyConName, ratioTyConName, ratioDataConName, realClassName, @@ -1930,9 +1999,9 @@ multMulTyConKey = mkPreludeTyConUnique 194 -} charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey, - floatDataConKey, intDataConKey, integerSDataConKey, nilDataConKey, + floatDataConKey, intDataConKey, nilDataConKey, ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey, - word8DataConKey, ioDataConKey, integerDataConKey, heqDataConKey, + word8DataConKey, ioDataConKey, heqDataConKey, coercibleDataConKey, eqDataConKey, nothingDataConKey, justDataConKey :: Unique charDataConKey = mkPreludeDataConUnique 1 @@ -1941,19 +2010,17 @@ doubleDataConKey = mkPreludeDataConUnique 3 falseDataConKey = mkPreludeDataConUnique 4 floatDataConKey = mkPreludeDataConUnique 5 intDataConKey = mkPreludeDataConUnique 6 -integerSDataConKey = mkPreludeDataConUnique 7 -nothingDataConKey = mkPreludeDataConUnique 8 -justDataConKey = mkPreludeDataConUnique 9 -eqDataConKey = mkPreludeDataConUnique 10 -nilDataConKey = mkPreludeDataConUnique 11 -ratioDataConKey = mkPreludeDataConUnique 12 -word8DataConKey = mkPreludeDataConUnique 13 -stableNameDataConKey = mkPreludeDataConUnique 14 -trueDataConKey = mkPreludeDataConUnique 15 -wordDataConKey = mkPreludeDataConUnique 16 -ioDataConKey = mkPreludeDataConUnique 17 -integerDataConKey = mkPreludeDataConUnique 18 -heqDataConKey = mkPreludeDataConUnique 19 +nothingDataConKey = mkPreludeDataConUnique 7 +justDataConKey = mkPreludeDataConUnique 8 +eqDataConKey = mkPreludeDataConUnique 9 +nilDataConKey = mkPreludeDataConUnique 10 +ratioDataConKey = mkPreludeDataConUnique 11 +word8DataConKey = mkPreludeDataConUnique 12 +stableNameDataConKey = mkPreludeDataConUnique 13 +trueDataConKey = mkPreludeDataConUnique 14 +wordDataConKey = mkPreludeDataConUnique 15 +ioDataConKey = mkPreludeDataConUnique 16 +heqDataConKey = mkPreludeDataConUnique 18 -- Generic data constructors crossDataConKey, inlDataConKey, inrDataConKey, genUnitDataConKey :: Unique @@ -2090,6 +2157,16 @@ oneDataConKey, manyDataConKey :: Unique oneDataConKey = mkPreludeDataConUnique 115 manyDataConKey = mkPreludeDataConUnique 116 +-- ghc-bignum +integerISDataConKey, integerINDataConKey, integerIPDataConKey, + naturalNSDataConKey, naturalNBDataConKey :: Unique +integerISDataConKey = mkPreludeDataConUnique 120 +integerINDataConKey = mkPreludeDataConUnique 121 +integerIPDataConKey = mkPreludeDataConUnique 122 +naturalNSDataConKey = mkPreludeDataConUnique 123 +naturalNBDataConKey = mkPreludeDataConUnique 124 + + ---------------- Template Haskell ------------------- -- GHC.Builtin.Names.TH: USES DataUniques 200-250 ----------------------------------------------------- @@ -2163,63 +2240,6 @@ sndIdKey = mkPreludeMiscIdUnique 42 otherwiseIdKey = mkPreludeMiscIdUnique 43 assertIdKey = mkPreludeMiscIdUnique 44 -mkIntegerIdKey, smallIntegerIdKey, wordToIntegerIdKey, - integerToWordIdKey, integerToIntIdKey, - integerToWord64IdKey, integerToInt64IdKey, - word64ToIntegerIdKey, int64ToIntegerIdKey, - plusIntegerIdKey, timesIntegerIdKey, minusIntegerIdKey, - negateIntegerIdKey, - eqIntegerPrimIdKey, neqIntegerPrimIdKey, absIntegerIdKey, signumIntegerIdKey, - leIntegerPrimIdKey, gtIntegerPrimIdKey, ltIntegerPrimIdKey, geIntegerPrimIdKey, - compareIntegerIdKey, quotRemIntegerIdKey, divModIntegerIdKey, - quotIntegerIdKey, remIntegerIdKey, divIntegerIdKey, modIntegerIdKey, - floatFromIntegerIdKey, doubleFromIntegerIdKey, - encodeFloatIntegerIdKey, encodeDoubleIntegerIdKey, - decodeDoubleIntegerIdKey, - gcdIntegerIdKey, lcmIntegerIdKey, - andIntegerIdKey, orIntegerIdKey, xorIntegerIdKey, complementIntegerIdKey, - shiftLIntegerIdKey, shiftRIntegerIdKey :: Unique -mkIntegerIdKey = mkPreludeMiscIdUnique 60 -smallIntegerIdKey = mkPreludeMiscIdUnique 61 -integerToWordIdKey = mkPreludeMiscIdUnique 62 -integerToIntIdKey = mkPreludeMiscIdUnique 63 -integerToWord64IdKey = mkPreludeMiscIdUnique 64 -integerToInt64IdKey = mkPreludeMiscIdUnique 65 -plusIntegerIdKey = mkPreludeMiscIdUnique 66 -timesIntegerIdKey = mkPreludeMiscIdUnique 67 -minusIntegerIdKey = mkPreludeMiscIdUnique 68 -negateIntegerIdKey = mkPreludeMiscIdUnique 69 -eqIntegerPrimIdKey = mkPreludeMiscIdUnique 70 -neqIntegerPrimIdKey = mkPreludeMiscIdUnique 71 -absIntegerIdKey = mkPreludeMiscIdUnique 72 -signumIntegerIdKey = mkPreludeMiscIdUnique 73 -leIntegerPrimIdKey = mkPreludeMiscIdUnique 74 -gtIntegerPrimIdKey = mkPreludeMiscIdUnique 75 -ltIntegerPrimIdKey = mkPreludeMiscIdUnique 76 -geIntegerPrimIdKey = mkPreludeMiscIdUnique 77 -compareIntegerIdKey = mkPreludeMiscIdUnique 78 -quotIntegerIdKey = mkPreludeMiscIdUnique 79 -remIntegerIdKey = mkPreludeMiscIdUnique 80 -divIntegerIdKey = mkPreludeMiscIdUnique 81 -modIntegerIdKey = mkPreludeMiscIdUnique 82 -divModIntegerIdKey = mkPreludeMiscIdUnique 83 -quotRemIntegerIdKey = mkPreludeMiscIdUnique 84 -floatFromIntegerIdKey = mkPreludeMiscIdUnique 85 -doubleFromIntegerIdKey = mkPreludeMiscIdUnique 86 -encodeFloatIntegerIdKey = mkPreludeMiscIdUnique 87 -encodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 88 -gcdIntegerIdKey = mkPreludeMiscIdUnique 89 -lcmIntegerIdKey = mkPreludeMiscIdUnique 90 -andIntegerIdKey = mkPreludeMiscIdUnique 91 -orIntegerIdKey = mkPreludeMiscIdUnique 92 -xorIntegerIdKey = mkPreludeMiscIdUnique 93 -complementIntegerIdKey = mkPreludeMiscIdUnique 94 -shiftLIntegerIdKey = mkPreludeMiscIdUnique 95 -shiftRIntegerIdKey = mkPreludeMiscIdUnique 96 -wordToIntegerIdKey = mkPreludeMiscIdUnique 97 -word64ToIntegerIdKey = mkPreludeMiscIdUnique 98 -int64ToIntegerIdKey = mkPreludeMiscIdUnique 99 -decodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 100 rootMainKey, runMainKey :: Unique rootMainKey = mkPreludeMiscIdUnique 101 @@ -2416,24 +2436,121 @@ fromStaticPtrClassOpKey = mkPreludeMiscIdUnique 560 makeStaticKey :: Unique makeStaticKey = mkPreludeMiscIdUnique 561 --- Natural -naturalFromIntegerIdKey, naturalToIntegerIdKey, plusNaturalIdKey, - minusNaturalIdKey, timesNaturalIdKey, mkNaturalIdKey, - naturalSDataConKey, wordToNaturalIdKey :: Unique -naturalFromIntegerIdKey = mkPreludeMiscIdUnique 562 -naturalToIntegerIdKey = mkPreludeMiscIdUnique 563 -plusNaturalIdKey = mkPreludeMiscIdUnique 564 -minusNaturalIdKey = mkPreludeMiscIdUnique 565 -timesNaturalIdKey = mkPreludeMiscIdUnique 566 -mkNaturalIdKey = mkPreludeMiscIdUnique 567 -naturalSDataConKey = mkPreludeMiscIdUnique 568 -wordToNaturalIdKey = mkPreludeMiscIdUnique 569 - -- Unsafe coercion proofs unsafeEqualityProofIdKey, unsafeCoercePrimIdKey :: Unique unsafeEqualityProofIdKey = mkPreludeMiscIdUnique 570 unsafeCoercePrimIdKey = mkPreludeMiscIdUnique 571 + +------------------------------------------------------ +-- ghc-bignum uses 600-699 uniques +------------------------------------------------------ + +integerFromNaturalIdKey + , integerToNaturalClampIdKey + , integerToWordIdKey + , integerToIntIdKey + , integerToWord64IdKey + , integerToInt64IdKey + , integerAddIdKey + , integerMulIdKey + , integerSubIdKey + , integerNegateIdKey + , integerEqPrimIdKey + , integerNePrimIdKey + , integerLePrimIdKey + , integerGtPrimIdKey + , integerLtPrimIdKey + , integerGePrimIdKey + , integerAbsIdKey + , integerSignumIdKey + , integerCompareIdKey + , integerQuotIdKey + , integerRemIdKey + , integerDivIdKey + , integerModIdKey + , integerDivModIdKey + , integerQuotRemIdKey + , integerToFloatIdKey + , integerToDoubleIdKey + , integerEncodeFloatIdKey + , integerEncodeDoubleIdKey + , integerGcdIdKey + , integerLcmIdKey + , integerAndIdKey + , integerOrIdKey + , integerXorIdKey + , integerComplementIdKey + , integerBitIdKey + , integerShiftLIdKey + , integerShiftRIdKey + , integerFromWordIdKey + , integerFromWord64IdKey + , integerFromInt64IdKey + , integerDecodeDoubleIdKey + , naturalToWordIdKey + , naturalAddIdKey + , naturalSubIdKey + , naturalMulIdKey + , naturalQuotIdKey + , naturalRemIdKey + , naturalQuotRemIdKey + , bignatFromWordListIdKey + :: Unique + +integerFromNaturalIdKey = mkPreludeMiscIdUnique 600 +integerToNaturalClampIdKey = mkPreludeMiscIdUnique 601 +integerToWordIdKey = mkPreludeMiscIdUnique 602 +integerToIntIdKey = mkPreludeMiscIdUnique 603 +integerToWord64IdKey = mkPreludeMiscIdUnique 604 +integerToInt64IdKey = mkPreludeMiscIdUnique 605 +integerAddIdKey = mkPreludeMiscIdUnique 606 +integerMulIdKey = mkPreludeMiscIdUnique 607 +integerSubIdKey = mkPreludeMiscIdUnique 608 +integerNegateIdKey = mkPreludeMiscIdUnique 609 +integerEqPrimIdKey = mkPreludeMiscIdUnique 610 +integerNePrimIdKey = mkPreludeMiscIdUnique 611 +integerLePrimIdKey = mkPreludeMiscIdUnique 612 +integerGtPrimIdKey = mkPreludeMiscIdUnique 613 +integerLtPrimIdKey = mkPreludeMiscIdUnique 614 +integerGePrimIdKey = mkPreludeMiscIdUnique 615 +integerAbsIdKey = mkPreludeMiscIdUnique 616 +integerSignumIdKey = mkPreludeMiscIdUnique 617 +integerCompareIdKey = mkPreludeMiscIdUnique 618 +integerQuotIdKey = mkPreludeMiscIdUnique 619 +integerRemIdKey = mkPreludeMiscIdUnique 620 +integerDivIdKey = mkPreludeMiscIdUnique 621 +integerModIdKey = mkPreludeMiscIdUnique 622 +integerDivModIdKey = mkPreludeMiscIdUnique 623 +integerQuotRemIdKey = mkPreludeMiscIdUnique 624 +integerToFloatIdKey = mkPreludeMiscIdUnique 625 +integerToDoubleIdKey = mkPreludeMiscIdUnique 626 +integerEncodeFloatIdKey = mkPreludeMiscIdUnique 627 +integerEncodeDoubleIdKey = mkPreludeMiscIdUnique 628 +integerGcdIdKey = mkPreludeMiscIdUnique 629 +integerLcmIdKey = mkPreludeMiscIdUnique 630 +integerAndIdKey = mkPreludeMiscIdUnique 631 +integerOrIdKey = mkPreludeMiscIdUnique 632 +integerXorIdKey = mkPreludeMiscIdUnique 633 +integerComplementIdKey = mkPreludeMiscIdUnique 634 +integerBitIdKey = mkPreludeMiscIdUnique 635 +integerShiftLIdKey = mkPreludeMiscIdUnique 636 +integerShiftRIdKey = mkPreludeMiscIdUnique 637 +integerFromWordIdKey = mkPreludeMiscIdUnique 638 +integerFromWord64IdKey = mkPreludeMiscIdUnique 639 +integerFromInt64IdKey = mkPreludeMiscIdUnique 640 +integerDecodeDoubleIdKey = mkPreludeMiscIdUnique 641 + +naturalToWordIdKey = mkPreludeMiscIdUnique 650 +naturalAddIdKey = mkPreludeMiscIdUnique 651 +naturalSubIdKey = mkPreludeMiscIdUnique 652 +naturalMulIdKey = mkPreludeMiscIdUnique 653 +naturalQuotIdKey = mkPreludeMiscIdUnique 654 +naturalRemIdKey = mkPreludeMiscIdUnique 655 +naturalQuotRemIdKey = mkPreludeMiscIdUnique 656 + +bignatFromWordListIdKey = mkPreludeMiscIdUnique 670 + {- ************************************************************************ * * diff --git a/compiler/GHC/Builtin/PrimOps.hs b/compiler/GHC/Builtin/PrimOps.hs index 86c3894f06..a4bd412c37 100644 --- a/compiler/GHC/Builtin/PrimOps.hs +++ b/compiler/GHC/Builtin/PrimOps.hs @@ -453,7 +453,7 @@ Duplicate YES NO just look at Control.Monad.ST.Lazy.Imp.strictToLazy! We get something like this p = case readMutVar# s v of - (# s', r #) -> (S# s', r) + (# s', r #) -> (State# s', r) s' = case p of (s', r) -> s' r = case p of (s', r) -> r diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs index 8d4b576993..d568851727 100644 --- a/compiler/GHC/Builtin/Types.hs +++ b/compiler/GHC/Builtin/Types.hs @@ -134,7 +134,16 @@ module GHC.Builtin.Types ( oneDataConTyCon, manyDataConTyCon, multMulTyCon, - unrestrictedFunTyCon, unrestrictedFunTyConName + unrestrictedFunTyCon, unrestrictedFunTyConName, + + -- * Bignum + integerTy, integerTyCon, integerTyConName, + integerISDataCon, integerISDataConName, + integerIPDataCon, integerIPDataConName, + integerINDataCon, integerINDataConName, + naturalTy, naturalTyCon, naturalTyConName, + naturalNSDataCon, naturalNSDataConName, + naturalNBDataCon, naturalNBDataConName ) where @@ -252,6 +261,8 @@ wiredInTyCons = [ -- Units are not treated like other tuples, because they , constraintKindTyCon , liftedTypeKindTyCon , multiplicityTyCon + , naturalTyCon + , integerTyCon ] mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name @@ -1827,3 +1838,98 @@ extractPromotedList tys = go tys | otherwise = pprPanic "extractPromotedList" (ppr tys) + + + +--------------------------------------- +-- ghc-bignum +--------------------------------------- + +integerTyConName + , integerISDataConName + , integerIPDataConName + , integerINDataConName + :: Name +integerTyConName + = mkWiredInTyConName + UserSyntax + gHC_NUM_INTEGER + (fsLit "Integer") + integerTyConKey + integerTyCon +integerISDataConName + = mkWiredInDataConName + UserSyntax + gHC_NUM_INTEGER + (fsLit "IS") + integerISDataConKey + integerISDataCon +integerIPDataConName + = mkWiredInDataConName + UserSyntax + gHC_NUM_INTEGER + (fsLit "IP") + integerIPDataConKey + integerIPDataCon +integerINDataConName + = mkWiredInDataConName + UserSyntax + gHC_NUM_INTEGER + (fsLit "IN") + integerINDataConKey + integerINDataCon + +integerTy :: Type +integerTy = mkTyConTy integerTyCon + +integerTyCon :: TyCon +integerTyCon = pcTyCon integerTyConName Nothing [] + [integerISDataCon, integerIPDataCon, integerINDataCon] + +integerISDataCon :: DataCon +integerISDataCon = pcDataCon integerISDataConName [] [intPrimTy] integerTyCon + +integerIPDataCon :: DataCon +integerIPDataCon = pcDataCon integerIPDataConName [] [byteArrayPrimTy] integerTyCon + +integerINDataCon :: DataCon +integerINDataCon = pcDataCon integerINDataConName [] [byteArrayPrimTy] integerTyCon + +naturalTyConName + , naturalNSDataConName + , naturalNBDataConName + :: Name +naturalTyConName + = mkWiredInTyConName + UserSyntax + gHC_NUM_NATURAL + (fsLit "Natural") + naturalTyConKey + naturalTyCon +naturalNSDataConName + = mkWiredInDataConName + UserSyntax + gHC_NUM_NATURAL + (fsLit "NS") + naturalNSDataConKey + naturalNSDataCon +naturalNBDataConName + = mkWiredInDataConName + UserSyntax + gHC_NUM_NATURAL + (fsLit "NB") + naturalNBDataConKey + naturalNBDataCon + +naturalTy :: Type +naturalTy = mkTyConTy naturalTyCon + +naturalTyCon :: TyCon +naturalTyCon = pcTyCon naturalTyConName Nothing [] + [naturalNSDataCon, naturalNBDataCon] + +naturalNSDataCon :: DataCon +naturalNSDataCon = pcDataCon naturalNSDataConName [] [wordPrimTy] naturalTyCon + +naturalNBDataCon :: DataCon +naturalNBDataCon = pcDataCon naturalNBDataConName [] [byteArrayPrimTy] naturalTyCon diff --git a/compiler/GHC/Builtin/Types.hs-boot b/compiler/GHC/Builtin/Types.hs-boot index db14a844d1..792faf939f 100644 --- a/compiler/GHC/Builtin/Types.hs-boot +++ b/compiler/GHC/Builtin/Types.hs-boot @@ -54,3 +54,5 @@ unrestrictedFunTyCon :: TyCon multMulTyCon :: TyCon tupleTyConName :: TupleSort -> Arity -> Name + +integerTy, naturalTy :: Type diff --git a/compiler/GHC/Builtin/Types/Prim.hs b/compiler/GHC/Builtin/Types/Prim.hs index bc319fca74..dc366bfd60 100644 --- a/compiler/GHC/Builtin/Types/Prim.hs +++ b/compiler/GHC/Builtin/Types/Prim.hs @@ -232,7 +232,7 @@ eqPhantPrimTyConName = mkBuiltInPrimTc (fsLit "~P#") eqPhantPrimTyConKe realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon arrayPrimTyConName = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon byteArrayPrimTyConName = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon -arrayArrayPrimTyConName = mkPrimTc (fsLit "ArrayArray#") arrayArrayPrimTyConKey arrayArrayPrimTyCon +arrayArrayPrimTyConName = mkPrimTc (fsLit "ArrayArray#") arrayArrayPrimTyConKey arrayArrayPrimTyCon smallArrayPrimTyConName = mkPrimTc (fsLit "SmallArray#") smallArrayPrimTyConKey smallArrayPrimTyCon mutableArrayPrimTyConName = mkPrimTc (fsLit "MutableArray#") mutableArrayPrimTyConKey mutableArrayPrimTyCon mutableByteArrayPrimTyConName = mkPrimTc (fsLit "MutableByteArray#") mutableByteArrayPrimTyConKey mutableByteArrayPrimTyCon diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs index 9ed0283394..48b6dc980d 100644 --- a/compiler/GHC/ByteCode/Asm.hs +++ b/compiler/GHC/ByteCode/Asm.hs @@ -453,7 +453,7 @@ assembleI platform i = case i of literal (LitChar c) = int (ord c) literal (LitString bs) = lit [BCONPtrStr bs] -- LitString requires a zero-terminator when emitted - literal (LitNumber nt i _) = case nt of + literal (LitNumber nt i) = case nt of LitNumInt -> int (fromIntegral i) LitNumWord -> int (fromIntegral i) LitNumInt64 -> int64 (fromIntegral i) diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs index 5653a71af2..7cc8d968b6 100644 --- a/compiler/GHC/Core.hs +++ b/compiler/GHC/Core.hs @@ -345,9 +345,10 @@ We have one literal, a literal Integer, that is lifted, and we don't allow in a LitAlt, because LitAlt cases don't do any evaluation. Also (see #5603) if you say case 3 of - S# x -> ... - J# _ _ -> ... -(where S#, J# are the constructors for Integer) we don't want the + IS x -> ... + IP _ -> ... + IN _ -> ... +(where IS, IP, IN are the constructors for Integer) we don't want the simplifier calling findAlt with argument (LitAlt 3). No no. Integer literals are an opaque encoding of an algebraic data type, not of an unlifted literal, like all the others. diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs index 40911f2a89..ccaa385801 100644 --- a/compiler/GHC/Core/Make.hs +++ b/compiler/GHC/Core/Make.hs @@ -14,7 +14,7 @@ module GHC.Core.Make ( -- * Constructing boxed literals mkWordExpr, mkWordExprWord, - mkIntExpr, mkIntExprInt, + mkIntExpr, mkIntExprInt, mkUncheckedIntExpr, mkIntegerExpr, mkNaturalExpr, mkFloatExpr, mkDoubleExpr, mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith, @@ -253,6 +253,11 @@ castBottomExpr e res_ty mkIntExpr :: Platform -> Integer -> CoreExpr -- Result = I# i :: Int mkIntExpr platform i = mkCoreConApps intDataCon [mkIntLit platform i] +-- | Create a 'CoreExpr' which will evaluate to the given @Int@. Don't check +-- that the number is in the range of the target platform @Int@ +mkUncheckedIntExpr :: Integer -> CoreExpr -- Result = I# i :: Int +mkUncheckedIntExpr i = mkCoreConApps intDataCon [Lit (mkLitIntUnchecked i)] + -- | Create a 'CoreExpr' which will evaluate to the given @Int@ mkIntExprInt :: Platform -> Int -> CoreExpr -- Result = I# i :: Int mkIntExprInt platform i = mkCoreConApps intDataCon [mkIntLitInt platform i] @@ -266,14 +271,12 @@ mkWordExprWord :: Platform -> Word -> CoreExpr mkWordExprWord platform w = mkCoreConApps wordDataCon [mkWordLitWord platform w] -- | Create a 'CoreExpr' which will evaluate to the given @Integer@ -mkIntegerExpr :: MonadThings m => Integer -> m CoreExpr -- Result :: Integer -mkIntegerExpr i = do t <- lookupTyCon integerTyConName - return (Lit (mkLitInteger i (mkTyConTy t))) +mkIntegerExpr :: Integer -> CoreExpr -- Result :: Integer +mkIntegerExpr i = Lit (mkLitInteger i) -- | Create a 'CoreExpr' which will evaluate to the given @Natural@ -mkNaturalExpr :: MonadThings m => Integer -> m CoreExpr -mkNaturalExpr i = do t <- lookupTyCon naturalTyConName - return (Lit (mkLitNatural i (mkTyConTy t))) +mkNaturalExpr :: Integer -> CoreExpr +mkNaturalExpr i = Lit (mkLitNatural i) -- | Create a 'CoreExpr' which will evaluate to the given @Float@ mkFloatExpr :: Float -> CoreExpr diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs index b0a83e5edb..de98dd0842 100644 --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/compiler/GHC/Core/Opt/ConstantFold.hs @@ -21,6 +21,7 @@ module GHC.Core.Opt.ConstantFold ( primOpRules , builtinRules , caseRules + , EnableBignumRules (..) ) where @@ -397,7 +398,7 @@ cmpOp platform cmp = go go (LitChar i1) (LitChar i2) = done (i1 `cmp` i2) go (LitFloat i1) (LitFloat i2) = done (i1 `cmp` i2) go (LitDouble i1) (LitDouble i2) = done (i1 `cmp` i2) - go (LitNumber nt1 i1 _) (LitNumber nt2 i2 _) + go (LitNumber nt1 i1) (LitNumber nt2 i2) | nt1 /= nt2 = Nothing | otherwise = done (i1 `cmp` i2) go _ _ = Nothing @@ -410,16 +411,15 @@ negOp env = \case (LitFloat f) -> Just (mkFloatVal env (-f)) (LitDouble 0.0) -> Nothing (LitDouble d) -> Just (mkDoubleVal env (-d)) - (LitNumber nt i t) - | litNumIsSigned nt -> Just (Lit (mkLitNumberWrap (roPlatform env) nt (-i) t)) + (LitNumber nt i) + | litNumIsSigned nt -> Just (Lit (mkLitNumberWrap (roPlatform env) nt (-i))) _ -> Nothing complementOp :: RuleOpts -> Literal -> Maybe CoreExpr -- Binary complement -complementOp env (LitNumber nt i t) = - Just (Lit (mkLitNumberWrap (roPlatform env) nt (complement i) t)) +complementOp env (LitNumber nt i) = + Just (Lit (mkLitNumberWrap (roPlatform env) nt (complement i))) complementOp _ _ = Nothing --------------------------- intOp2 :: (Integral a, Integral b) => (a -> b -> Integer) -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr @@ -428,17 +428,17 @@ intOp2 = intOp2' . const intOp2' :: (Integral a, Integral b) => (RuleOpts -> a -> b -> Integer) -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr -intOp2' op env (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) = +intOp2' op env (LitNumber LitNumInt i1) (LitNumber LitNumInt i2) = let o = op env in intResult (roPlatform env) (fromInteger i1 `o` fromInteger i2) -intOp2' _ _ _ _ = Nothing -- Could find LitLit +intOp2' _ _ _ _ = Nothing intOpC2 :: (Integral a, Integral b) => (a -> b -> Integer) -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr -intOpC2 op env (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) = do +intOpC2 op env (LitNumber LitNumInt i1) (LitNumber LitNumInt i2) = do intCResult (roPlatform env) (fromInteger i1 `op` fromInteger i2) -intOpC2 _ _ _ _ = Nothing -- Could find LitLit +intOpC2 _ _ _ _ = Nothing shiftRightLogical :: Platform -> Integer -> Int -> Integer -- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do @@ -463,16 +463,16 @@ retLitNoC l = do platform <- getPlatform wordOp2 :: (Integral a, Integral b) => (a -> b -> Integer) -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr -wordOp2 op env (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _) +wordOp2 op env (LitNumber LitNumWord w1) (LitNumber LitNumWord w2) = wordResult (roPlatform env) (fromInteger w1 `op` fromInteger w2) -wordOp2 _ _ _ _ = Nothing -- Could find LitLit +wordOp2 _ _ _ _ = Nothing wordOpC2 :: (Integral a, Integral b) => (a -> b -> Integer) -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr -wordOpC2 op env (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _) = +wordOpC2 op env (LitNumber LitNumWord w1) (LitNumber LitNumWord w2) = wordCResult (roPlatform env) (fromInteger w1 `op` fromInteger w2) -wordOpC2 _ _ _ _ = Nothing -- Could find LitLit +wordOpC2 _ _ _ _ = Nothing shiftRule :: (Platform -> Integer -> Int -> Integer) -> RuleM CoreExpr -- Shifts take an Int; hence third arg of op is Int @@ -481,21 +481,21 @@ shiftRule :: (Platform -> Integer -> Int -> Integer) -> RuleM CoreExpr -- SllOp, SrlOp :: Word# -> Int# -> Word# shiftRule shift_op = do { platform <- getPlatform - ; [e1, Lit (LitNumber LitNumInt shift_len _)] <- getArgs + ; [e1, Lit (LitNumber LitNumInt shift_len)] <- getArgs ; case e1 of _ | shift_len == 0 -> return e1 -- See Note [Guarding against silly shifts] | shift_len < 0 || shift_len > toInteger (platformWordSizeInBits platform) - -> return $ Lit $ mkLitNumberWrap platform LitNumInt 0 (exprType e1) + -> return $ Lit $ mkLitNumberWrap platform LitNumInt 0 -- Do the shift at type Integer, but shift length is Int - Lit (LitNumber nt x t) + Lit (LitNumber nt x) | 0 < shift_len , shift_len <= toInteger (platformWordSizeInBits platform) -> let op = shift_op platform y = x `op` fromInteger shift_len - in liftMaybe $ Just (Lit (mkLitNumberWrap platform nt y t)) + in liftMaybe $ Just (Lit (mkLitNumberWrap platform nt y)) _ -> mzero } @@ -584,7 +584,7 @@ mkRuleFn _ _ _ _ = Nothing isMinBound :: Platform -> Literal -> Bool isMinBound _ (LitChar c) = c == minBound -isMinBound platform (LitNumber nt i _) = case nt of +isMinBound platform (LitNumber nt i) = case nt of LitNumInt -> i == platformMinInt platform LitNumInt64 -> i == toInteger (minBound :: Int64) LitNumWord -> i == 0 @@ -595,7 +595,7 @@ isMinBound _ _ = False isMaxBound :: Platform -> Literal -> Bool isMaxBound _ (LitChar c) = c == maxBound -isMaxBound platform (LitNumber nt i _) = case nt of +isMaxBound platform (LitNumber nt i) = case nt of LitNumInt -> i == platformMaxInt platform LitNumInt64 -> i == toInteger (maxBound :: Int64) LitNumWord -> i == platformMaxWord platform @@ -672,7 +672,7 @@ narrowSubsumesAnd and_primop narrw n = do [Var primop_id `App` x `App` y] <- getArgs matchPrimOpId and_primop primop_id let mask = bit n -1 - g v (Lit (LitNumber _ m _)) = do + g v (Lit (LitNumber _ m)) = do guard (m .&. mask == mask) return (Var (mkPrimOpId narrw) `App` v) g _ _ = mzero @@ -1061,7 +1061,7 @@ tagToEnumRule :: RuleM CoreExpr -- If data T a = A | B | C -- then tagToEnum# (T ty) 2# --> B ty tagToEnumRule = do - [Type ty, Lit (LitNumber LitNumInt i _)] <- getArgs + [Type ty, Lit (LitNumber LitNumInt i)] <- getArgs case splitTyConApp_maybe ty of Just (tycon, tc_args) | isEnumerationTyCon tycon -> do let tag = fromInteger i @@ -1254,9 +1254,11 @@ bindings (see occurAnalysePgm), which sorts out the dependency, so all is fine. -} -builtinRules :: [CoreRule] +newtype EnableBignumRules = EnableBignumRules Bool + +builtinRules :: EnableBignumRules -> [CoreRule] -- Rules for non-primops that can't be expressed using a RULE pragma -builtinRules +builtinRules enableBignumRules = [BuiltinRule { ru_name = fsLit "AppendLitString", ru_fn = unpackCStringFoldrName, ru_nargs = 4, ru_try = match_append_lit_C }, @@ -1278,7 +1280,7 @@ builtinRules [ nonZeroLit 1 >> binaryLit (intOp2 div) , leftZero zeroi , do - [arg, Lit (LitNumber LitNumInt d _)] <- getArgs + [arg, Lit (LitNumber LitNumInt d)] <- getArgs Just n <- return $ exactLog2 d platform <- getPlatform return $ Var (mkPrimOpId ISraOp) `App` arg `App` mkIntVal platform n @@ -1288,98 +1290,100 @@ builtinRules [ nonZeroLit 1 >> binaryLit (intOp2 mod) , leftZero zeroi , do - [arg, Lit (LitNumber LitNumInt d _)] <- getArgs + [arg, Lit (LitNumber LitNumInt d)] <- getArgs Just _ <- return $ exactLog2 d platform <- getPlatform return $ Var (mkPrimOpId AndIOp) `App` arg `App` mkIntVal platform (d - 1) ] ] - ++ builtinIntegerRules - ++ builtinNaturalRules + ++ builtinBignumRules enableBignumRules {-# NOINLINE builtinRules #-} -- there is no benefit to inlining these yet, despite this, GHC produces -- unfoldings for this regardless since the floated list entries look small. -builtinIntegerRules :: [CoreRule] -builtinIntegerRules = - [rule_IntToInteger "smallInteger" smallIntegerName, - rule_WordToInteger "wordToInteger" wordToIntegerName, - rule_Int64ToInteger "int64ToInteger" int64ToIntegerName, - rule_Word64ToInteger "word64ToInteger" word64ToIntegerName, - rule_convert "integerToWord" integerToWordName mkWordLitWord, - rule_convert "integerToInt" integerToIntName mkIntLitInt, - rule_convert "integerToWord64" integerToWord64Name (\_ -> mkWord64LitWord64), - rule_convert "integerToInt64" integerToInt64Name (\_ -> mkInt64LitInt64), - rule_binop "plusInteger" plusIntegerName (+), - rule_binop "minusInteger" minusIntegerName (-), - rule_binop "timesInteger" timesIntegerName (*), - rule_unop "negateInteger" negateIntegerName negate, - rule_binop_Prim "eqInteger#" eqIntegerPrimName (==), - rule_binop_Prim "neqInteger#" neqIntegerPrimName (/=), - rule_unop "absInteger" absIntegerName abs, - rule_unop "signumInteger" signumIntegerName signum, - rule_binop_Prim "leInteger#" leIntegerPrimName (<=), - rule_binop_Prim "gtInteger#" gtIntegerPrimName (>), - rule_binop_Prim "ltInteger#" ltIntegerPrimName (<), - rule_binop_Prim "geInteger#" geIntegerPrimName (>=), - rule_binop_Ordering "compareInteger" compareIntegerName compare, - rule_encodeFloat "encodeFloatInteger" encodeFloatIntegerName mkFloatLitFloat, - rule_convert "floatFromInteger" floatFromIntegerName (\_ -> mkFloatLitFloat), - rule_encodeFloat "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble, - rule_decodeDouble "decodeDoubleInteger" decodeDoubleIntegerName, - rule_convert "doubleFromInteger" doubleFromIntegerName (\_ -> mkDoubleLitDouble), - rule_rationalTo "rationalToFloat" rationalToFloatName mkFloatExpr, - rule_rationalTo "rationalToDouble" rationalToDoubleName mkDoubleExpr, - rule_binop "gcdInteger" gcdIntegerName gcd, - rule_binop "lcmInteger" lcmIntegerName lcm, - rule_binop "andInteger" andIntegerName (.&.), - rule_binop "orInteger" orIntegerName (.|.), - rule_binop "xorInteger" xorIntegerName xor, - rule_unop "complementInteger" complementIntegerName complement, - rule_shift_op "shiftLInteger" shiftLIntegerName shiftL, - rule_shift_op "shiftRInteger" shiftRIntegerName shiftR, - rule_bitInteger "bitInteger" bitIntegerName, - -- See Note [Integer division constant folding] in libraries/base/GHC/Real.hs - rule_divop_one "quotInteger" quotIntegerName quot, - rule_divop_one "remInteger" remIntegerName rem, - rule_divop_one "divInteger" divIntegerName div, - rule_divop_one "modInteger" modIntegerName mod, - rule_divop_both "divModInteger" divModIntegerName divMod, - rule_divop_both "quotRemInteger" quotRemIntegerName 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 - rule_XToIntegerToX "smallIntegerToInt" integerToIntName smallIntegerName, - rule_XToIntegerToX "wordToIntegerToWord" integerToWordName wordToIntegerName, - rule_XToIntegerToX "int64ToIntegerToInt64" integerToInt64Name int64ToIntegerName, - rule_XToIntegerToX "word64ToIntegerToWord64" integerToWord64Name word64ToIntegerName, - rule_smallIntegerTo "smallIntegerToWord" integerToWordName Int2WordOp, - rule_smallIntegerTo "smallIntegerToFloat" floatFromIntegerName Int2FloatOp, - rule_smallIntegerTo "smallIntegerToDouble" doubleFromIntegerName Int2DoubleOp - ] +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 mkWordLitWord + , rule_convert "Integer -> Int#" integerToIntName mkIntLitInt + , rule_convert "Integer -> Word64#" integerToWord64Name (\_ -> mkWord64LitWord64) + , rule_convert "Integer -> Int64#" integerToInt64Name (\_ -> mkInt64LitInt64) + , 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) + , rule_encodeFloat "integerEncodeDouble" integerEncodeDoubleName mkDoubleLitDouble + , rule_decodeDouble "integerDecodeDouble" integerDecodeDoubleName + , rule_convert "integerToDouble" integerToDoubleName (\_ -> mkDoubleLitDouble) + , 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 Int2WordOp + , rule_smallIntegerTo "IS -> Float" integerToFloatName Int2FloatOp + , rule_smallIntegerTo "IS -> Double" integerToDoubleName Int2DoubleOp + , rule_passthrough "Word# -> Natural -> Word#" naturalToWordName naturalNSDataConName + + , rule_IntegerToNaturalClamp "Integer -> Natural (clamp)" integerToNaturalClampName + , 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_IntToInteger str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_IntToInteger } - rule_WordToInteger str name + rule_IntegerFromLitNum str name = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_WordToInteger } - rule_Int64ToInteger str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_Int64ToInteger } - rule_Word64ToInteger str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_Word64ToInteger } + 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_bitInteger str name + rule_integerBit str name = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_bitInteger } - rule_binop str name op + 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 @@ -1403,40 +1407,24 @@ builtinIntegerRules = rule_decodeDouble str name = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, ru_try = match_decodeDouble } - rule_XToIntegerToX str name toIntegerName + rule_passthrough str name toIntegerName = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_XToIntegerToX toIntegerName } + 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 } - -builtinNaturalRules :: [CoreRule] -builtinNaturalRules = - [rule_binop "plusNatural" plusNaturalName (+) - ,rule_partial_binop "minusNatural" minusNaturalName (\a b -> if a >= b then Just (a - b) else Nothing) - ,rule_binop "timesNatural" timesNaturalName (*) - ,rule_NaturalFromInteger "naturalFromInteger" naturalFromIntegerName - ,rule_NaturalToInteger "naturalToInteger" naturalToIntegerName - ,rule_WordToNatural "wordToNatural" wordToNaturalName - ] - where rule_binop str name op + rule_IntegerToNaturalClamp str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_IntegerToNaturalClamp } + rule_binopn str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, ru_try = match_Natural_binop op } - rule_partial_binop str name 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 } - rule_NaturalToInteger str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_NaturalToInteger } - rule_NaturalFromInteger str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_NaturalFromInteger } - rule_WordToNatural str name - = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_WordToNatural } --------------------------------------------------- -- The rule is this: @@ -1567,83 +1555,27 @@ match_magicDict [Type _, Var wrap `App` Type a `App` Type _ `App` f, x, y ] match_magicDict _ = Nothing -------------------------------------------------- --- Integer rules --- smallInteger (79::Int#) = 79::Integer --- wordToInteger (79::Word#) = 79::Integer --- Similarly Int64, Word64 - -match_IntToInteger :: RuleFun -match_IntToInteger = match_IntToInteger_unop id - -match_WordToInteger :: RuleFun -match_WordToInteger _ id_unf id [xl] - | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl - = case splitFunTy_maybe (idType id) of - Just (_, _, integerTy) -> - Just (Lit (mkLitInteger x integerTy)) - _ -> - panic "match_WordToInteger: Id has the wrong type" -match_WordToInteger _ _ _ _ = Nothing - -match_Int64ToInteger :: RuleFun -match_Int64ToInteger _ id_unf id [xl] - | Just (LitNumber LitNumInt64 x _) <- exprIsLiteral_maybe id_unf xl - = case splitFunTy_maybe (idType id) of - Just (_, _, integerTy) -> - Just (Lit (mkLitInteger x integerTy)) - _ -> - panic "match_Int64ToInteger: Id has the wrong type" -match_Int64ToInteger _ _ _ _ = Nothing - -match_Word64ToInteger :: RuleFun -match_Word64ToInteger _ id_unf id [xl] - | Just (LitNumber LitNumWord64 x _) <- exprIsLiteral_maybe id_unf xl - = case splitFunTy_maybe (idType id) of - Just (_, _, integerTy) -> - Just (Lit (mkLitInteger x integerTy)) - _ -> - panic "match_Word64ToInteger: Id has the wrong type" -match_Word64ToInteger _ _ _ _ = Nothing - -match_NaturalToInteger :: RuleFun -match_NaturalToInteger _ id_unf id [xl] - | Just (LitNumber LitNumNatural x _) <- exprIsLiteral_maybe id_unf xl - = case splitFunTy_maybe (idType id) of - Just (_, _, naturalTy) -> - Just (Lit (LitNumber LitNumInteger x naturalTy)) - _ -> - panic "match_NaturalToInteger: Id has the wrong type" -match_NaturalToInteger _ _ _ _ = 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_NaturalFromInteger :: RuleFun -match_NaturalFromInteger _ id_unf id [xl] - | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl - , x >= 0 - = case splitFunTy_maybe (idType id) of - Just (_, _, naturalTy) -> - Just (Lit (LitNumber LitNumNatural x naturalTy)) - _ -> - panic "match_NaturalFromInteger: Id has the wrong type" -match_NaturalFromInteger _ _ _ _ = Nothing - -match_WordToNatural :: RuleFun -match_WordToNatural _ id_unf id [xl] - | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl - = case splitFunTy_maybe (idType id) of - Just (_, _, naturalTy) -> - Just (Lit (LitNumber LitNumNatural x naturalTy)) - _ -> - panic "match_WordToNatural: Id has the wrong type" -match_WordToNatural _ _ _ _ = 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 ------------------------------------------------- -{- Note [Rewriting bitInteger] +{- Note [Rewriting integerBit] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For most types the bitInteger operation can be implemented in terms of shifts. -The integer-gmp package, however, can do substantially better than this if +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 bitInteger rule above provides constant folding +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 @@ -1654,23 +1586,19 @@ should expect some funniness given that they will have at very least ignored a warning in this case. -} -match_bitInteger :: RuleFun --- Just for GHC.Integer.Type.bitInteger :: Int# -> Integer -match_bitInteger env id_unf fn [arg] - | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf arg +-- | 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 <= (toInteger (platformWordSizeInBits (roPlatform env)) - 1) + , x <= fromIntegral (platformWordSizeInBits (roPlatform env)) -- Make sure x is small enough to yield a decently small integer -- Attempting to construct the Integer for - -- (bitInteger 9223372036854775807#) + -- (integerBit 9223372036854775807#) -- would be a bad idea (#14959) , let x_int = fromIntegral x :: Int - = case splitFunTy_maybe (idType fn) of - Just (_, _, integerTy) - -> Just (Lit (LitNumber LitNumInteger (bit x_int) integerTy)) - _ -> panic "match_IntToInteger_unop: Id has the wrong type" - -match_bitInteger _ _ _ _ = Nothing + = Just (Lit (mkLitInteger (bit x_int))) +match_integerBit _ _ _ _ = Nothing ------------------------------------------------- @@ -1678,92 +1606,83 @@ match_Integer_convert :: Num a => (Platform -> a -> Expr CoreBndr) -> RuleFun match_Integer_convert convert env id_unf _ [xl] - | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl + | Just (LitNumber LitNumInteger x) <- exprIsLiteral_maybe id_unf xl = Just (convert (roPlatform env) (fromInteger x)) match_Integer_convert _ _ _ _ _ = Nothing match_Integer_unop :: (Integer -> Integer) -> RuleFun match_Integer_unop unop _ id_unf _ [xl] - | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl - = Just (Lit (LitNumber LitNumInteger (unop x) i)) + | Just (LitNumber LitNumInteger x) <- exprIsLiteral_maybe id_unf xl + = Just (Lit (LitNumber LitNumInteger (unop x))) match_Integer_unop _ _ _ _ _ = Nothing -match_IntToInteger_unop :: (Integer -> Integer) -> RuleFun -match_IntToInteger_unop unop _ id_unf fn [xl] - | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf xl - = case splitFunTy_maybe (idType fn) of - Just (_, _, integerTy) -> - Just (Lit (LitNumber LitNumInteger (unop x) integerTy)) - _ -> - panic "match_IntToInteger_unop: Id has the wrong type" -match_IntToInteger_unop _ _ _ _ _ = Nothing - match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun match_Integer_binop binop _ id_unf _ [xl,yl] - | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl - = Just (Lit (mkLitInteger (x `binop` y) i)) + | 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 i) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf yl - = Just (Lit (mkLitNatural (x `binop` y) i)) + | 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 i) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf 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 i)) + = 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 t) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf 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 [t,t] [Lit (mkLitInteger r t), Lit (mkLitInteger s t)] + = 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 i) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf 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) i)) + = Just (Lit (mkLitInteger (x `divop` y))) match_Integer_divop_one _ _ _ _ _ = Nothing match_Integer_shift_op :: (Integer -> Int -> Integer) -> RuleFun --- Used for shiftLInteger, shiftRInteger :: Integer -> Int# -> Integer +-- 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 i) <- exprIsLiteral_maybe id_unf xl - , Just (LitNumber LitNumInt y _) <- exprIsLiteral_maybe id_unf 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) i)) + = 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 (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 (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 @@ -1774,8 +1693,8 @@ 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 (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 @@ -1793,8 +1712,8 @@ 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 + | 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 @@ -1804,26 +1723,26 @@ match_decodeDouble env id_unf fn [xl] | Just (LitDouble x) <- exprIsLiteral_maybe id_unf xl = case splitFunTy_maybe (idType fn) of Just (_, _, res) - | Just [_lev1, _lev2, integerTy, intHashTy] <- tyConAppArgs_maybe res + | Just [_lev1, _lev2, _integerTy, intHashTy] <- tyConAppArgs_maybe res -> case decodeFloat (fromRational x :: Double) of (y, z) -> Just $ mkCoreUbxTup [integerTy, intHashTy] - [Lit (mkLitInteger y integerTy), + [Lit (mkLitInteger y), Lit (mkLitInt (roPlatform env) (toInteger z))] _ -> pprPanic "match_decodeDouble: Id has the wrong type" (ppr fn <+> dcolon <+> ppr (idType fn)) match_decodeDouble _ _ _ _ = Nothing -match_XToIntegerToX :: Name -> RuleFun -match_XToIntegerToX n _ _ _ [App (Var x) y] +match_passthrough :: Name -> RuleFun +match_passthrough n _ _ _ [App (Var x) y] | idName x == n = Just y -match_XToIntegerToX _ _ _ _ _ = Nothing +match_passthrough _ _ _ _ _ = Nothing match_smallIntegerTo :: PrimOp -> RuleFun match_smallIntegerTo primOp _ _ _ [App (Var x) y] - | idName x == smallIntegerName + | idName x == integerISDataConName = Just $ App (Var (mkPrimOpId primOp)) y match_smallIntegerTo _ _ _ _ _ = Nothing @@ -2214,7 +2133,7 @@ tx_con_tte platform (DataAlt dc) -- See Note [caseRules for tagToEnum] tx_con_dtt :: Type -> AltCon -> Maybe AltCon tx_con_dtt _ DEFAULT = Just DEFAULT -tx_con_dtt ty (LitAlt (LitNumber LitNumInt i _)) +tx_con_dtt ty (LitAlt (LitNumber LitNumInt i)) | tag >= 0 , tag < n_data_cons = Just (DataAlt (data_cons !! tag)) -- tag is zero-indexed, as is (!!) diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index 4833d1e499..87ad9e69c5 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -4,6 +4,8 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} + module GHC.Core.SimpleOpt ( -- ** Simple expression optimiser simpleOptPgm, simpleOptExpr, simpleOptExprWith, @@ -32,7 +34,7 @@ import {-# SOURCE #-} GHC.Core.Unfold( mkUnfolding ) import GHC.Core.Make ( FloatBind(..) ) import GHC.Core.Ppr ( pprCoreBindings, pprRules ) import GHC.Core.Opt.OccurAnal( occurAnalyseExpr, occurAnalysePgm ) -import GHC.Types.Literal ( Literal(LitString) ) +import GHC.Types.Literal import GHC.Types.Id import GHC.Types.Id.Info ( unfoldingInfo, setUnfoldingInfo, setRuleInfo, IdInfo (..) ) import GHC.Types.Var ( isNonCoVarId ) @@ -1242,8 +1244,18 @@ exprIsLiteral_maybe env@(_, id_unf) e = case e of Lit l -> Just l Tick _ e' -> exprIsLiteral_maybe env e' -- dubious? - Var v | Just rhs <- expandUnfolding_maybe (id_unf v) - -> exprIsLiteral_maybe env rhs + Var v + | Just rhs <- expandUnfolding_maybe (id_unf v) + , Just l <- exprIsLiteral_maybe env rhs + -> Just l + Var v + | Just rhs <- expandUnfolding_maybe (id_unf v) + , Just (_env,_fb,dc,_tys,[arg]) <- exprIsConApp_maybe env rhs + , Just (LitNumber _ i) <- exprIsLiteral_maybe env arg + -> if + | dc == naturalNSDataCon -> Just (mkLitNatural i) + | dc == integerISDataCon -> Just (mkLitInteger i) + | otherwise -> Nothing _ -> Nothing {- diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs index b614c87248..01c0a99638 100644 --- a/compiler/GHC/Core/Unfold.hs +++ b/compiler/GHC/Core/Unfold.hs @@ -807,8 +807,8 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr -- | Finds a nominal size of a string literal. litSize :: Literal -> Int -- Used by GHC.Core.Unfold.sizeExpr -litSize (LitNumber LitNumInteger _ _) = 100 -- Note [Size of literal integers] -litSize (LitNumber LitNumNatural _ _) = 100 +litSize (LitNumber LitNumInteger _) = 100 -- Note [Size of literal integers] +litSize (LitNumber LitNumNatural _) = 100 litSize (LitString str) = 10 + 10 * ((BS.length str + 3) `div` 4) -- If size could be 0 then @f "x"@ might be too small -- [Sept03: make literal strings a bit bigger to avoid fruitless @@ -958,10 +958,10 @@ Conclusion: Note [Literal integer size] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Literal integers *can* be big (mkInteger [...coefficients...]), but -need not be (S# n). We just use an arbitrary big-ish constant here +need not be (IS n). We just use an arbitrary big-ish constant here so that, in particular, we don't inline top-level defns like - n = S# 5 -There's no point in doing so -- any optimisations will see the S# + n = IS 5 +There's no point in doing so -- any optimisations will see the IS through n's unfolding. Nor will a big size inhibit unfoldings functions that mention a literal Integer, because the float-out pass will float all those constants to top level. diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs index a24fc52c69..73acd2a19f 100644 --- a/compiler/GHC/CoreToByteCode.hs +++ b/compiler/GHC/CoreToByteCode.hs @@ -1091,8 +1091,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple | otherwise = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG)) my_discr (LitAlt l, _, _) - = case l of LitNumber LitNumInt i _ -> DiscrI (fromInteger i) - LitNumber LitNumWord w _ -> DiscrW (fromInteger w) + = case l of LitNumber LitNumInt i -> DiscrI (fromInteger i) + LitNumber LitNumWord w -> DiscrW (fromInteger w) LitFloat r -> DiscrF (fromRational r) LitDouble r -> DiscrD (fromRational r) LitChar i -> DiscrI (ord i) @@ -1619,14 +1619,14 @@ pushAtom _ _ (AnnLit lit) = do wordsToBytes platform size_words) case lit of - LitLabel _ _ _ -> code N - LitFloat _ -> code F - LitDouble _ -> code D - LitChar _ -> code N - LitNullAddr -> code N - LitString _ -> code N - LitRubbish -> code N - LitNumber nt _ _ -> case nt of + LitLabel _ _ _ -> code N + LitFloat _ -> code F + LitDouble _ -> code D + LitChar _ -> code N + LitNullAddr -> code N + LitString _ -> code N + LitRubbish -> code N + LitNumber nt _ -> case nt of LitNumInt -> code N LitNumWord -> code N LitNumInt64 -> code L diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs index 42369fe45b..795a3d8b08 100644 --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -372,8 +372,8 @@ coreToStgExpr -- No LitInteger's or LitNatural's should be left by the time this is called. -- CorePrep should have converted them all to a real core representation. -coreToStgExpr (Lit (LitNumber LitNumInteger _ _)) = panic "coreToStgExpr: LitInteger" -coreToStgExpr (Lit (LitNumber LitNumNatural _ _)) = panic "coreToStgExpr: LitNatural" +coreToStgExpr (Lit (LitNumber LitNumInteger _)) = panic "coreToStgExpr: LitInteger" +coreToStgExpr (Lit (LitNumber LitNumNatural _)) = panic "coreToStgExpr: LitNatural" coreToStgExpr (Lit l) = return (StgLit l) coreToStgExpr (App (Lit LitRubbish) _some_unlifted_type) -- We lower 'LitRubbish' to @()@ here, which is much easier than doing it in diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index e4139139a8..42a59e00a3 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -9,11 +9,12 @@ Core pass to saturate constructors and PrimOps {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -module GHC.CoreToStg.Prep ( - corePrepPgm, corePrepExpr, cvtLitInteger, cvtLitNatural, - lookupMkIntegerName, lookupIntegerSDataConName, - lookupMkNaturalName, lookupNaturalSDataConName - ) where +module GHC.CoreToStg.Prep + ( corePrepPgm + , corePrepExpr + , mkConvertNumLiteral + ) +where #include "HsVersions.h" @@ -59,7 +60,8 @@ import GHC.Data.FastString import GHC.Types.Name ( NamedThing(..), nameSrcSpan, isInternalName ) import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) import Data.Bits -import GHC.Utils.Monad ( mapAccumLM ) +import GHC.Utils.Monad ( mapAccumLM ) +import Data.List ( unfoldr ) import Control.Monad import GHC.Types.CostCentre ( CostCentre, ccFromThisModule ) import qualified Data.Set as S @@ -115,19 +117,14 @@ The goal of this pass is to prepare for code generation. 9. Replace (lazy e) by e. See Note [lazyId magic] in GHC.Types.Id.Make Also replace (noinline e) by e. -10. Convert (LitInteger i t) into the core representation - for the Integer i. Normally this uses mkInteger, but if - we are using the integer-gmp implementation then there is a - special case where we use the S# constructor for Integers that - are in the range of Int. +10. Convert bignum literals (LitNatural and LitInteger) into their + core representation. -11. Same for LitNatural. - -12. Uphold tick consistency while doing this: We move ticks out of +11. Uphold tick consistency while doing this: We move ticks out of (non-type) applications where we can, and make sure that we annotate according to scoping rules when floating. -13. Collect cost centres (including cost centres in unfoldings) if we're in +12. Collect cost centres (including cost centres in unfoldings) if we're in profiling mode. We have to do this here beucase we won't have unfoldings after this pass (see `zapUnfolding` and Note [Drop unfoldings and rules]. @@ -182,7 +179,7 @@ corePrepPgm hsc_env this_mod mod_loc binds data_tycons = (text "CorePrep"<+>brackets (ppr this_mod)) (const ()) $ do us <- mkSplitUniqSupply 's' - initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env + initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env let cost_centres | WayProf `S.member` ways dflags @@ -204,14 +201,15 @@ corePrepPgm hsc_env this_mod mod_loc binds data_tycons = where dflags = hsc_dflags hsc_env -corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr -corePrepExpr dflags hsc_env expr = +corePrepExpr :: HscEnv -> CoreExpr -> IO CoreExpr +corePrepExpr hsc_env expr = do + let dflags = hsc_dflags hsc_env withTiming dflags (text "CorePrep [expr]") (const ()) $ do - us <- mkSplitUniqSupply 's' - initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env - let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr) - dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr) - return new_expr + us <- mkSplitUniqSupply 's' + initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env + let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr) + dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr) + return new_expr corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats -- Note [Floating out of top level bindings] @@ -571,12 +569,10 @@ cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr) cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr) -cpeRhsE env (Lit (LitNumber LitNumInteger i _)) - = cpeRhsE env (cvtLitInteger (targetPlatform (cpe_dynFlags env)) (getMkIntegerId env) - (cpe_integerSDataCon env) i) -cpeRhsE env (Lit (LitNumber LitNumNatural i _)) - = cpeRhsE env (cvtLitNatural (targetPlatform (cpe_dynFlags env)) (getMkNaturalId env) - (cpe_naturalSDataCon env) i) +cpeRhsE env expr@(Lit (LitNumber nt i)) + = case cpe_convertNumLit env nt i of + Nothing -> return (emptyFloats, expr) + Just e -> cpeRhsE env e cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr) cpeRhsE env expr@(Var {}) = cpeApp env expr cpeRhsE env expr@(App {}) = cpeApp env expr @@ -650,46 +646,6 @@ cpeRhsE env (Case scrut bndr ty alts) ; rhs' <- cpeBodyNF env2 rhs ; return (con, bs', rhs') } -cvtLitInteger :: Platform -> Id -> Maybe DataCon -> Integer -> CoreExpr --- Here we convert a literal Integer to the low-level --- representation. Exactly how we do this depends on the --- library that implements Integer. If it's GMP we --- use the S# data constructor for small literals. --- See Note [Integer literals] in GHC.Types.Literal -cvtLitInteger platform _ (Just sdatacon) i - | platformInIntRange platform i -- Special case for small integers - = mkConApp sdatacon [Lit (mkLitInt platform i)] - -cvtLitInteger platform mk_integer _ i - = mkApps (Var mk_integer) [isNonNegative, ints] - where isNonNegative = if i < 0 then mkConApp falseDataCon [] - else mkConApp trueDataCon [] - ints = mkListExpr intTy (f (abs i)) - f 0 = [] - f x = let low = x .&. mask - high = x `shiftR` bits - in mkConApp intDataCon [Lit (mkLitInt platform low)] : f high - bits = 31 - mask = 2 ^ bits - 1 - -cvtLitNatural :: Platform -> Id -> Maybe DataCon -> Integer -> CoreExpr --- Here we convert a literal Natural to the low-level --- representation. --- See Note [Natural literals] in GHC.Types.Literal -cvtLitNatural platform _ (Just sdatacon) i - | platformInWordRange platform i -- Special case for small naturals - = mkConApp sdatacon [Lit (mkLitWord platform i)] - -cvtLitNatural platform mk_natural _ i - = mkApps (Var mk_natural) [words] - where words = mkListExpr wordTy (f i) - f 0 = [] - f x = let low = x .&. mask - high = x `shiftR` bits - in mkConApp wordDataCon [Lit (mkLitWord platform low)] : f high - bits = 32 - mask = 2 ^ bits - 1 - -- --------------------------------------------------------------------------- -- CpeBody: produces a result satisfying CpeBody -- --------------------------------------------------------------------------- @@ -1524,72 +1480,106 @@ data CorePrepEnv -- 3. To let us inline trivial RHSs of non top-level let-bindings, -- see Note [lazyId magic], Note [Inlining in CorePrep] -- and Note [CorePrep inlines trivial CoreExpr not Id] (#12076) - , cpe_mkIntegerId :: Id - , cpe_mkNaturalId :: Id - , cpe_integerSDataCon :: Maybe DataCon - , cpe_naturalSDataCon :: Maybe DataCon + + , cpe_convertNumLit :: LitNumType -> Integer -> Maybe CoreExpr + -- ^ Convert some numeric literals (Integer, Natural) into their + -- final Core form } -lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id -lookupMkIntegerName dflags hsc_env - = guardIntegerUse dflags $ liftM tyThingId $ - lookupGlobal hsc_env mkIntegerName - -lookupMkNaturalName :: DynFlags -> HscEnv -> IO Id -lookupMkNaturalName dflags hsc_env - = guardNaturalUse dflags $ liftM tyThingId $ - lookupGlobal hsc_env mkNaturalName - --- See Note [The integer library] in GHC.Builtin.Names -lookupIntegerSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon) -lookupIntegerSDataConName dflags hsc_env = case integerLibrary dflags of - IntegerGMP -> guardIntegerUse dflags $ liftM (Just . tyThingDataCon) $ - lookupGlobal hsc_env integerSDataConName - IntegerSimple -> return Nothing - -lookupNaturalSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon) -lookupNaturalSDataConName dflags hsc_env = case integerLibrary dflags of - IntegerGMP -> guardNaturalUse dflags $ liftM (Just . tyThingDataCon) $ - lookupGlobal hsc_env naturalSDataConName - IntegerSimple -> return Nothing - --- | Helper for 'lookupMkIntegerName', 'lookupIntegerSDataConName' -guardIntegerUse :: DynFlags -> IO a -> IO a -guardIntegerUse dflags act - | homeUnitId dflags == primUnitId - = return $ panic "Can't use Integer in ghc-prim" - | homeUnitId dflags == integerUnitId - = return $ panic "Can't use Integer in integer-*" - | otherwise = act - --- | Helper for 'lookupMkNaturalName', 'lookupNaturalSDataConName' --- --- Just like we can't use Integer literals in `integer-*`, we can't use Natural --- literals in `base`. If we do, we get interface loading error for GHC.Natural. -guardNaturalUse :: DynFlags -> IO a -> IO a -guardNaturalUse dflags act - | homeUnitId dflags == primUnitId - = return $ panic "Can't use Natural in ghc-prim" - | homeUnitId dflags == integerUnitId - = return $ panic "Can't use Natural in integer-*" - | homeUnitId dflags == baseUnitId - = return $ panic "Can't use Natural in base" - | otherwise = act - -mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv -mkInitialCorePrepEnv dflags hsc_env - = do mkIntegerId <- lookupMkIntegerName dflags hsc_env - mkNaturalId <- lookupMkNaturalName dflags hsc_env - integerSDataCon <- lookupIntegerSDataConName dflags hsc_env - naturalSDataCon <- lookupNaturalSDataConName dflags hsc_env - return $ CPE { - cpe_dynFlags = dflags, - cpe_env = emptyVarEnv, - cpe_mkIntegerId = mkIntegerId, - cpe_mkNaturalId = mkNaturalId, - cpe_integerSDataCon = integerSDataCon, - cpe_naturalSDataCon = naturalSDataCon - } +-- | Create a function that converts Bignum literals into their final CoreExpr +mkConvertNumLiteral + :: HscEnv + -> IO (LitNumType -> Integer -> Maybe CoreExpr) +mkConvertNumLiteral hsc_env = do + let + dflags = hsc_dflags hsc_env + platform = targetPlatform dflags + guardBignum act + | homeUnitId dflags == primUnitId + = return $ panic "Bignum literals are not supported in ghc-prim" + | homeUnitId dflags == bignumUnitId + = return $ panic "Bignum literals are not supported in ghc-bignum" + | otherwise = act + + lookupBignumId n = guardBignum (tyThingId <$> lookupGlobal hsc_env n) + + -- The lookup is done here but the failure (panic) is reported lazily when we + -- try to access the `bigNatFromWordList` function. + -- + -- If we ever get built-in ByteArray# literals, we could avoid the lookup by + -- directly using the Integer/Natural wired-in constructors for big numbers. + + bignatFromWordListId <- lookupBignumId bignatFromWordListName + + let + convertNumLit nt i = case nt of + LitNumInteger -> Just (convertInteger i) + LitNumNatural -> Just (convertNatural i) + _ -> Nothing + + convertInteger i + | platformInIntRange platform i -- fit in a Int# + = mkConApp integerISDataCon [Lit (mkLitInt platform i)] + + | otherwise -- build a BigNat and embed into IN or IP + = let con = if i > 0 then integerIPDataCon else integerINDataCon + in mkBigNum con (convertBignatPrim (abs i)) + + convertNatural i + | platformInWordRange platform i -- fit in a Word# + = mkConApp naturalNSDataCon [Lit (mkLitWord platform i)] + + | otherwise --build a BigNat and embed into NB + = mkBigNum naturalNBDataCon (convertBignatPrim i) + + -- we can't simply generate: + -- + -- NB (bigNatFromWordList# [W# 10, W# 20]) + -- + -- using `mkConApp` because it isn't in ANF form. Instead we generate: + -- + -- case bigNatFromWordList# [W# 10, W# 20] of ba { DEFAULT -> NB ba } + -- + -- via `mkCoreApps` + + mkBigNum con ba = mkCoreApps (Var (dataConWorkId con)) [ba] + + convertBignatPrim i = + let + target = targetPlatform dflags + + -- ByteArray# literals aren't supported (yet). Were they supported, + -- we would use them directly. We would need to handle + -- wordSize/endianness conversion between host and target + -- wordSize = platformWordSize platform + -- byteOrder = platformByteOrder platform + + -- For now we build a list of Words and we produce + -- `bigNatFromWordList# list_of_words` + + words = mkListExpr wordTy (reverse (unfoldr f i)) + where + f 0 = Nothing + f x = let low = x .&. mask + high = x `shiftR` bits + in Just (mkConApp wordDataCon [Lit (mkLitWord platform low)], high) + bits = platformWordSizeInBits target + mask = 2 ^ bits - 1 + + in mkApps (Var bignatFromWordListId) [words] + + + return convertNumLit + + +mkInitialCorePrepEnv :: HscEnv -> IO CorePrepEnv +mkInitialCorePrepEnv hsc_env = do + convertNumLit <- mkConvertNumLiteral hsc_env + return $ CPE + { cpe_dynFlags = hsc_dflags hsc_env + , cpe_env = emptyVarEnv + , cpe_convertNumLit = convertNumLit + } extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv extendCorePrepEnv cpe id id' @@ -1610,12 +1600,6 @@ lookupCorePrepEnv cpe id Nothing -> Var id Just exp -> exp -getMkIntegerId :: CorePrepEnv -> Id -getMkIntegerId = cpe_mkIntegerId - -getMkNaturalId :: CorePrepEnv -> Id -getMkNaturalId = cpe_mkNaturalId - ------------------------------------------------------------------------------ -- Cloning binders -- --------------------------------------------------------------------------- diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index eff29cdcd7..85c68bb8e6 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -193,7 +193,7 @@ import GHC.Iface.Ext.Debug ( diffFile, validateScopes ) newHscEnv :: DynFlags -> IO HscEnv newHscEnv dflags = do - eps_var <- newIORef initExternalPackageState + eps_var <- newIORef (initExternalPackageState dflags) us <- mkSplitUniqSupply 'r' nc_var <- newIORef (initNameCache us knownKeyNames) fc_var <- newIORef emptyInstalledModuleEnv @@ -1888,16 +1888,14 @@ hscCompileCoreExpr hsc_env = hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue hscCompileCoreExpr' hsc_env srcspan ds_expr - = do { let dflags = hsc_dflags hsc_env - - {- Simplify it -} - ; simpl_expr <- simplifyExpr hsc_env ds_expr + = do { {- Simplify it -} + simpl_expr <- simplifyExpr hsc_env ds_expr {- Tidy it (temporary, until coreSat does cloning) -} ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr {- Prepare for codegen -} - ; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr + ; prepd_expr <- corePrepExpr hsc_env tidy_expr {- Lint if necessary -} ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 51a90138b3..0d08d0cc26 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -128,8 +128,6 @@ module GHC.Driver.Session ( sOpt_i, sExtraGccViaCFlags, sTargetPlatformString, - sIntegerLibrary, - sIntegerLibraryType, sGhcWithInterpreter, sGhcWithNativeCodeGen, sGhcWithSMP, @@ -139,7 +137,6 @@ module GHC.Driver.Session ( sGhcThreaded, sGhcDebugged, sGhcRtsWithLibdw, - IntegerLibrary(..), GhcNameVersion(..), FileSettings(..), PlatformMisc(..), @@ -460,9 +457,6 @@ data DynFlags = DynFlags { platformConstants :: PlatformConstants, rawSettings :: [(String, String)], - integerLibrary :: IntegerLibrary, - -- ^ IntegerGMP or IntegerSimple. Set at configure time, but may be overridden - -- by GHC-API users. See Note [The integer library] in GHC.Builtin.Names llvmConfig :: LlvmConfig, -- ^ N.B. It's important that this field is lazy since we load the LLVM -- configuration lazily. See Note [LLVM Configuration] in GHC.SysTools. @@ -1286,7 +1280,6 @@ defaultDynFlags mySettings llvmConfig = ghcMode = CompManager, ghcLink = LinkBinary, hscTarget = defaultHscTarget (sTargetPlatform mySettings) (sPlatformMisc mySettings), - integerLibrary = sIntegerLibraryType mySettings, verbosity = 0, optLevel = 0, debugLevel = 0, diff --git a/compiler/GHC/HsToCore/Foreign/Call.hs b/compiler/GHC/HsToCore/Foreign/Call.hs index 69639268ea..102f2b3697 100644 --- a/compiler/GHC/HsToCore/Foreign/Call.hs +++ b/compiler/GHC/HsToCore/Foreign/Call.hs @@ -59,7 +59,7 @@ unboxing any boxed primitive arguments and boxing the result if desired. The state stuff just consists of adding in -@PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place. +@PrimIO (\ s -> case s of { State# s# -> ... })@ in an appropriate place. The unboxing is straightforward, as all information needed to unbox is available from the type. For each boxed-primitive argument, we diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs index 3052ff18af..cb38aef33a 100644 --- a/compiler/GHC/HsToCore/Match/Literal.hs +++ b/compiler/GHC/HsToCore/Match/Literal.hs @@ -101,13 +101,13 @@ dsLit l = do HsDoublePrim _ d -> return (Lit (LitDouble (fl_value d))) HsChar _ c -> return (mkCharExpr c) HsString _ str -> mkStringExprFS str - HsInteger _ i _ -> mkIntegerExpr i + HsInteger _ i _ -> return (mkIntegerExpr i) HsInt _ i -> return (mkIntExpr platform (il_value i)) HsRat _ (FL _ _ val) ty -> do - num <- mkIntegerExpr (numerator val) - denom <- mkIntegerExpr (denominator val) return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom]) where + num = mkIntegerExpr (numerator val) + denom = mkIntegerExpr (denominator val) (ratio_data_con, integer_ty) = case tcSplitTyConApp ty of (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey) diff --git a/compiler/GHC/HsToCore/PmCheck/Types.hs b/compiler/GHC/HsToCore/PmCheck/Types.hs index 50000d7ace..9267555380 100644 --- a/compiler/GHC/HsToCore/PmCheck/Types.hs +++ b/compiler/GHC/HsToCore/PmCheck/Types.hs @@ -288,7 +288,7 @@ literalToPmLit ty l = PmLit ty <$> go l go (LitFloat r) = Just (PmLitRat r) go (LitDouble r) = Just (PmLitRat r) go (LitString s) = Just (PmLitString (mkFastStringByteString s)) - go (LitNumber _ i _) = Just (PmLitInt i) + go (LitNumber _ i) = Just (PmLitInt i) go _ = Nothing negatePmLit :: PmLit -> Maybe PmLit diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index 6aedef187a..056931e86c 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -1364,8 +1364,7 @@ repTy (HsIParamTy _ n t) = do repTy ty = notHandled "Exotic form of type" (ppr ty) repTyLit :: HsTyLit -> MetaM (Core (M TH.TyLit)) -repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i - rep2 numTyLitName [iExpr] +repTyLit (HsNumTy _ i) = rep2 numTyLitName [mkIntegerExpr i] repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s ; rep2 strTyLitName [s'] } @@ -2755,8 +2754,7 @@ repLiteral lit _ -> Nothing mk_integer :: Integer -> MetaM (HsLit GhcRn) -mk_integer i = do integer_ty <- lookupType integerTyConName - return $ HsInteger NoSourceText i integer_ty +mk_integer i = return $ HsInteger NoSourceText i integerTy mk_rational :: FractionalLit -> MetaM (HsLit GhcRn) mk_rational r = do rat_ty <- lookupType rationalTyConName @@ -2913,7 +2911,7 @@ coreIntLit i = do platform <- getPlatform return (MkC (mkIntExprInt platform i)) coreIntegerLit :: MonadThings m => Integer -> m (Core Integer) -coreIntegerLit i = fmap MkC (mkIntegerExpr i) +coreIntegerLit i = pure (MkC (mkIntegerExpr i)) coreVar :: Id -> Core TH.Name -- The Id has type Name coreVar id = MkC (Var id) diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index 53560ca732..4ba0e1966a 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -53,7 +53,7 @@ import GHC.Settings.Constants import GHC.Builtin.Names import GHC.Builtin.Utils import GHC.Builtin.PrimOps ( allThePrimOps, primOpFixity, primOpOcc ) -import GHC.Types.Id.Make ( seqId ) +import GHC.Types.Id.Make ( seqId, EnableBignumRules(..) ) import GHC.Core.Rules import GHC.Core.TyCon import GHC.Types.Annotations @@ -1016,8 +1016,8 @@ readIface wanted_mod file_path ********************************************************* -} -initExternalPackageState :: ExternalPackageState -initExternalPackageState +initExternalPackageState :: DynFlags -> ExternalPackageState +initExternalPackageState dflags = EPS { eps_is_boot = emptyUFM, eps_PIT = emptyPackageIfaceTable, @@ -1025,7 +1025,7 @@ initExternalPackageState eps_PTE = emptyTypeEnv, eps_inst_env = emptyInstEnv, eps_fam_inst_env = emptyFamInstEnv, - eps_rule_base = mkRuleBase builtinRules, + eps_rule_base = mkRuleBase builtinRules', -- Initialise the EPS rule pool with the built-in rules eps_mod_fam_inst_env = emptyModuleEnv, @@ -1033,8 +1033,14 @@ initExternalPackageState eps_ann_env = emptyAnnEnv, eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0 , n_insts_in = 0, n_insts_out = 0 - , n_rules_in = length builtinRules, n_rules_out = 0 } + , n_rules_in = length builtinRules', n_rules_out = 0 } } + where + enableBignumRules + | homeUnitId dflags == primUnitId = EnableBignumRules False + | homeUnitId dflags == bignumUnitId = EnableBignumRules False + | otherwise = EnableBignumRules True + builtinRules' = builtinRules enableBignumRules {- ********************************************************* diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index 060a27297f..9f8ba03bc1 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -57,7 +57,6 @@ import GHC.Core.Class import GHC.Core.TyCon import GHC.Core.ConLike import GHC.Core.DataCon -import GHC.Builtin.Names import GHC.Builtin.Types import GHC.Types.Literal import GHC.Types.Var as Var @@ -1404,18 +1403,6 @@ tcIfaceTickish (IfaceSource src name) = return (SourceNote src name) ------------------------- tcIfaceLit :: Literal -> IfL Literal --- Integer literals deserialise to (LitInteger i <error thunk>) --- so tcIfaceLit just fills in the type. --- See Note [Integer literals] in GHC.Types.Literal -tcIfaceLit (LitNumber LitNumInteger i _) - = do t <- tcIfaceTyConByName integerTyConName - return (mkLitInteger i (mkTyConTy t)) --- Natural literals deserialise to (LitNatural i <error thunk>) --- so tcIfaceLit just fills in the type. --- See Note [Natural literals] in GHC.Types.Literal -tcIfaceLit (LitNumber LitNumNatural i _) - = do t <- tcIfaceTyConByName naturalTyConName - return (mkLitNatural i (mkTyConTy t)) tcIfaceLit lit = return lit ------------------------- @@ -1747,11 +1734,6 @@ tcIfaceGlobal name -- the constructor (A and B) means that GHC will always typecheck -- this expression *after* typechecking T. -tcIfaceTyConByName :: IfExtName -> IfL TyCon -tcIfaceTyConByName name - = do { thing <- tcIfaceGlobal name - ; return (tyThingTyCon thing) } - tcIfaceTyCon :: IfaceTyCon -> IfL TyCon tcIfaceTyCon (IfaceTyCon name info) = do { thing <- tcIfaceGlobal name diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs index f3a6122144..73f11a98d0 100644 --- a/compiler/GHC/Runtime/Heap/Inspect.hs +++ b/compiler/GHC/Runtime/Heap/Inspect.hs @@ -55,7 +55,6 @@ import GHC.Utils.Misc import GHC.Types.Var.Set import GHC.Types.Basic ( Boxity(..) ) import GHC.Builtin.Types.Prim -import GHC.Builtin.Names import GHC.Builtin.Types import GHC.Driver.Session import GHC.Utils.Outputable as Ppr @@ -66,21 +65,13 @@ import GHC.IO (throwIO) import Control.Monad import Data.Maybe -import Data.List ((\\)) -#if defined(INTEGER_GMP) +import Data.List import GHC.Exts -import Data.Array.Base -import GHC.Integer.GMP.Internals -#elif defined(INTEGER_SIMPLE) -import GHC.Exts -import GHC.Integer.Simple.Internals -#endif import qualified Data.Sequence as Seq import Data.Sequence (viewl, ViewL(..)) import Foreign import System.IO.Unsafe - --------------------------------------------- -- * A representation of semi evaluated Terms --------------------------------------------- @@ -330,11 +321,12 @@ cPprTermBase y = . subTerms) , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2) ppr_list - , ifTerm' (isTyCon intTyCon . ty) ppr_int - , ifTerm' (isTyCon charTyCon . ty) ppr_char - , ifTerm' (isTyCon floatTyCon . ty) ppr_float - , ifTerm' (isTyCon doubleTyCon . ty) ppr_double - , ifTerm' (isIntegerTy . ty) ppr_integer + , ifTerm' (isTyCon intTyCon . ty) ppr_int + , ifTerm' (isTyCon charTyCon . ty) ppr_char + , ifTerm' (isTyCon floatTyCon . ty) ppr_float + , ifTerm' (isTyCon doubleTyCon . ty) ppr_double + , ifTerm' (isTyCon integerTyCon . ty) ppr_integer + , ifTerm' (isTyCon naturalTyCon . ty) ppr_natural ] where ifTerm :: (Term -> Bool) @@ -357,10 +349,6 @@ cPprTermBase y = (tc,_) <- tcSplitTyConApp_maybe ty return (a_tc == tc) - isIntegerTy ty = fromMaybe False $ do - (tc,_) <- tcSplitTyConApp_maybe ty - return (tyConName tc == integerTyConName) - ppr_int, ppr_char, ppr_float, ppr_double :: Precedence -> Term -> m (Maybe SDoc) ppr_int _ Term{subTerms=[Prim{valRaw=[w]}]} = @@ -393,63 +381,53 @@ cPprTermBase y = return (Just (Ppr.double f)) ppr_double _ _ = return Nothing - ppr_integer :: Precedence -> Term -> m (Maybe SDoc) -#if defined(INTEGER_GMP) - -- Reconstructing Integers is a bit of a pain. This depends deeply - -- on the integer-gmp representation, so it'll break if that - -- changes (but there are several tests in - -- tests/ghci.debugger/scripts that will tell us if this is wrong). - -- - -- data Integer - -- = S# Int# - -- | Jp# {-# UNPACK #-} !BigNat - -- | Jn# {-# UNPACK #-} !BigNat - -- - -- data BigNat = BN# ByteArray# - -- - ppr_integer _ Term{subTerms=[Prim{valRaw=[W# w]}]} = - return (Just (Ppr.integer (S# (word2Int# w)))) - ppr_integer _ Term{dc=Right con, - subTerms=[Term{subTerms=[Prim{valRaw=ws}]}]} = do - -- We don't need to worry about sizes that are not an integral - -- number of words, because luckily GMP uses arrays of words - -- (see GMP_LIMB_SHIFT). + ppr_bignat :: Bool -> Precedence -> [Word] -> m (Maybe SDoc) + ppr_bignat sign _ ws = do let - !(UArray _ _ _ arr#) = listArray (0,length ws-1) ws - constr - | "Jp#" <- getOccString (dataConName con) = Jp# - | otherwise = Jn# - return (Just (Ppr.integer (constr (BN# arr#)))) -#elif defined(INTEGER_SIMPLE) - -- As with the GMP case, this depends deeply on the integer-simple - -- representation. + wordSize = finiteBitSize (0 :: Word) -- does the word size depend on the target? + makeInteger n _ [] = n + makeInteger n s (x:xs) = makeInteger (n + (fromIntegral x `shiftL` s)) (s + wordSize) xs + signf = case sign of + False -> 1 + True -> -1 + return $ Just $ Ppr.integer $ signf * (makeInteger 0 0 ws) + + -- Reconstructing Bignums is a bit of a pain. This depends deeply on their + -- representation, so it'll break if that changes (but there are several + -- tests in tests/ghci.debugger/scripts that will tell us if this is wrong). -- - -- @ - -- data Integer = Positive !Digits | Negative !Digits | Naught + -- data Integer + -- = IS !Int# + -- | IP !BigNat + -- | IN !BigNat -- - -- data Digits = Some !Word# !Digits - -- | None - -- @ + -- data Natural + -- = NS !Word# + -- | NB !BigNat -- - -- NB: the above has some type synonyms expanded out for the sake of brevity - ppr_integer _ Term{subTerms=[]} = - return (Just (Ppr.integer Naught)) - ppr_integer _ Term{dc=Right con, subTerms=[digitTerm]} - | Just digits <- get_digits digitTerm - = return (Just (Ppr.integer (constr digits))) - where - get_digits :: Term -> Maybe Digits - get_digits Term{subTerms=[]} = Just None - get_digits Term{subTerms=[Prim{valRaw=[W# w]},t]} - = Some w <$> get_digits t - get_digits _ = Nothing - - constr - | "Positive" <- getOccString (dataConName con) = Positive - | otherwise = Negative -#endif + -- type BigNat = ByteArray# + + ppr_integer :: Precedence -> Term -> m (Maybe SDoc) + ppr_integer _ Term{dc=Right con, subTerms=[Prim{valRaw=ws}]} + | con == integerISDataCon + , [W# w] <- ws + = return (Just (Ppr.integer (fromIntegral (I# (word2Int# w))))) + ppr_integer p Term{dc=Right con, subTerms=[Term{subTerms=[Prim{valRaw=ws}]}]} + | con == integerIPDataCon = ppr_bignat False p ws + | con == integerINDataCon = ppr_bignat True p ws + | otherwise = panic "Unexpected Integer constructor" ppr_integer _ _ = return Nothing + ppr_natural :: Precedence -> Term -> m (Maybe SDoc) + ppr_natural _ Term{dc=Right con, subTerms=[Prim{valRaw=ws}]} + | con == naturalNSDataCon + , [w] <- ws + = return (Just (Ppr.integer (fromIntegral w))) + ppr_natural p Term{dc=Right con, subTerms=[Term{subTerms=[Prim{valRaw=ws}]}]} + | con == naturalNBDataCon = ppr_bignat False p ws + | otherwise = panic "Unexpected Natural constructor" + ppr_natural _ _ = return Nothing + --Note pprinting of list terms is not lazy ppr_list :: Precedence -> Term -> m SDoc ppr_list p (Term{subTerms=[h,t]}) = do diff --git a/compiler/GHC/Settings.hs b/compiler/GHC/Settings.hs index df2f817393..6223e48704 100644 --- a/compiler/GHC/Settings.hs +++ b/compiler/GHC/Settings.hs @@ -55,8 +55,6 @@ module GHC.Settings , sOpt_i , sExtraGccViaCFlags , sTargetPlatformString - , sIntegerLibrary - , sIntegerLibraryType , sGhcWithInterpreter , sGhcWithNativeCodeGen , sGhcWithSMP @@ -262,10 +260,6 @@ sExtraGccViaCFlags = toolSettings_extraGccViaCFlags . sToolSettings sTargetPlatformString :: Settings -> String sTargetPlatformString = platformMisc_targetPlatformString . sPlatformMisc -sIntegerLibrary :: Settings -> String -sIntegerLibrary = platformMisc_integerLibrary . sPlatformMisc -sIntegerLibraryType :: Settings -> IntegerLibrary -sIntegerLibraryType = platformMisc_integerLibraryType . sPlatformMisc sGhcWithInterpreter :: Settings -> Bool sGhcWithInterpreter = platformMisc_ghcWithInterpreter . sPlatformMisc sGhcWithNativeCodeGen :: Settings -> Bool diff --git a/compiler/GHC/Settings/IO.hs b/compiler/GHC/Settings/IO.hs index c43e28cef9..a3478f4497 100644 --- a/compiler/GHC/Settings/IO.hs +++ b/compiler/GHC/Settings/IO.hs @@ -149,19 +149,6 @@ initSettings top_dir = do let iserv_prog = libexec "ghc-iserv" - integerLibrary <- getSetting "integer library" - integerLibraryType <- case integerLibrary of - "integer-gmp" -> pure IntegerGMP - "integer-simple" -> pure IntegerSimple - _ -> pgmError $ unwords - [ "Entry for" - , show "integer library" - , "must be one of" - , show "integer-gmp" - , "or" - , show "integer-simple" - ] - ghcWithInterpreter <- getBooleanSetting "Use interpreter" ghcWithNativeCodeGen <- getBooleanSetting "Use native code generator" ghcWithSMP <- getBooleanSetting "Support SMP" @@ -229,8 +216,6 @@ initSettings top_dir = do , sTargetPlatform = platform , sPlatformMisc = PlatformMisc { platformMisc_targetPlatformString = targetPlatformString - , platformMisc_integerLibrary = integerLibrary - , platformMisc_integerLibraryType = integerLibraryType , platformMisc_ghcWithInterpreter = ghcWithInterpreter , platformMisc_ghcWithNativeCodeGen = ghcWithNativeCodeGen , platformMisc_ghcWithSMP = ghcWithSMP diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs index e78a58894d..1cce87248b 100644 --- a/compiler/GHC/Stg/Unarise.hs +++ b/compiler/GHC/Stg/Unarise.hs @@ -215,7 +215,7 @@ import GHC.Utils.Outputable import GHC.Types.RepType import GHC.Stg.Syntax import GHC.Core.Type -import GHC.Builtin.Types.Prim (intPrimTy,wordPrimTy,word64PrimTy) +import GHC.Builtin.Types.Prim (intPrimTy) import GHC.Builtin.Types import GHC.Types.Unique.Supply import GHC.Utils.Misc @@ -481,7 +481,7 @@ unariseSumAlt rho _ (DEFAULT, _, e) unariseSumAlt rho args (DataAlt sumCon, bs, e) = do let rho' = mapSumIdBinders bs args rho e' <- unariseExpr rho' e - return ( LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon)) intPrimTy), [], e' ) + return ( LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon))), [], e' ) unariseSumAlt _ scrt alt = pprPanic "unariseSumAlt" (ppr scrt $$ ppr alt) @@ -567,7 +567,7 @@ mkUbxSum dc ty_args args0 tag = dataConTag dc layout' = layoutUbxSum sum_slots (mapMaybe (typeSlotTy . stgArgType) args0) - tag_arg = StgLitArg (LitNumber LitNumInt (fromIntegral tag) intPrimTy) + tag_arg = StgLitArg (LitNumber LitNumInt (fromIntegral tag)) arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0) mkTupArgs :: Int -> [SlotTy] -> IM.IntMap StgArg -> [StgArg] @@ -592,8 +592,8 @@ mkUbxSum dc ty_args args0 -- ubxSumRubbishArg :: SlotTy -> StgArg ubxSumRubbishArg PtrSlot = StgVarArg aBSENT_SUM_FIELD_ERROR_ID -ubxSumRubbishArg WordSlot = StgLitArg (LitNumber LitNumWord 0 wordPrimTy) -ubxSumRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0 word64PrimTy) +ubxSumRubbishArg WordSlot = StgLitArg (LitNumber LitNumWord 0) +ubxSumRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0) ubxSumRubbishArg FloatSlot = StgLitArg (LitFloat 0) ubxSumRubbishArg DoubleSlot = StgLitArg (LitDouble 0) diff --git a/compiler/GHC/StgToCmm/DataCon.hs b/compiler/GHC/StgToCmm/DataCon.hs index 3f4c94abdd..d319ca7d17 100644 --- a/compiler/GHC/StgToCmm/DataCon.hs +++ b/compiler/GHC/StgToCmm/DataCon.hs @@ -311,7 +311,7 @@ precomputedStaticConInfo_maybe dflags binder con [arg] platform = targetPlatform dflags intClosure = maybeIntLikeCon con charClosure = maybeCharLikeCon con - getClosurePayload (NonVoid (StgLitArg (LitNumber LitNumInt val _))) = Just val + getClosurePayload (NonVoid (StgLitArg (LitNumber LitNumInt val))) = Just val getClosurePayload (NonVoid (StgLitArg (LitChar val))) = Just $ (fromIntegral . ord $ val) getClosurePayload _ = Nothing -- Avoid over/underflow by comparisons at type Integer! diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs index 6367f5e839..2814948189 100644 --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -103,10 +103,10 @@ mkSimpleLit platform = \case (LitChar c) -> CmmInt (fromIntegral (ord c)) (wordWidth platform) LitNullAddr -> zeroCLit platform - (LitNumber LitNumInt i _) -> CmmInt i (wordWidth platform) - (LitNumber LitNumInt64 i _) -> CmmInt i W64 - (LitNumber LitNumWord i _) -> CmmInt i (wordWidth platform) - (LitNumber LitNumWord64 i _) -> CmmInt i W64 + (LitNumber LitNumInt i) -> CmmInt i (wordWidth platform) + (LitNumber LitNumInt64 i) -> CmmInt i W64 + (LitNumber LitNumWord i) -> CmmInt i (wordWidth platform) + (LitNumber LitNumWord64 i) -> CmmInt i W64 (LitFloat r) -> CmmFloat r W32 (LitDouble r) -> CmmFloat r W64 (LitLabel fs ms fod) @@ -495,7 +495,7 @@ emitCmmLitSwitch scrut branches deflt = do -- We find the necessary type information in the literals in the branches let signed = case head branches of - (LitNumber nt _ _, _) -> litNumIsSigned nt + (LitNumber nt _, _) -> litNumIsSigned nt _ -> False let range | signed = (platformMinInt platform, platformMaxInt platform) diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs index f2f4065bc0..f0c6d17aaa 100644 --- a/compiler/GHC/Tc/Instance/Class.hs +++ b/compiler/GHC/Tc/Instance/Class.hs @@ -354,9 +354,7 @@ matchKnownNat :: DynFlags -- See Note [Shortcut solving: overlap] -> Class -> [Type] -> TcM ClsInstResult matchKnownNat _ _ clas [ty] -- clas = KnownNat - | Just n <- isNumLitTy ty = do - et <- mkNaturalExpr n - makeLitDict clas ty et + | Just n <- isNumLitTy ty = makeLitDict clas ty (mkNaturalExpr n) matchKnownNat df sc clas tys = matchInstEnv df sc clas tys -- See Note [Fabricating Evidence for Literals in Backpack] for why -- this lookup into the instance environment is required. diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs index d027209d04..827801a850 100644 --- a/compiler/GHC/Tc/Utils/Instantiate.hs +++ b/compiler/GHC/Tc/Utils/Instantiate.hs @@ -48,7 +48,7 @@ import GHC.Tc.Types.Origin import GHC.Tc.Utils.Env import GHC.Tc.Types.Evidence import GHC.Core.InstEnv -import GHC.Builtin.Types ( heqDataCon, eqDataCon ) +import GHC.Builtin.Types ( heqDataCon, eqDataCon, integerTyConName ) import GHC.Core ( isOrphan ) import GHC.Tc.Instance.FunDeps import GHC.Tc.Utils.TcMType diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index e485b667af..f1d82c1228 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -271,6 +271,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this tcg_fix_env = emptyNameEnv, tcg_field_env = emptyNameEnv, tcg_default = if moduleUnit mod == primUnit + || moduleUnit mod == bignumUnit then Just [] -- See Note [Default types] else Nothing, tcg_type_env = emptyNameEnv, @@ -390,10 +391,10 @@ initTcInteractive hsc_env thing_inside {- Note [Default types] ~~~~~~~~~~~~~~~~~~~~~~~ -The Integer type is simply not available in package ghc-prim (it is -declared in integer-gmp). So we set the defaulting types to (Just -[]), meaning there are no default types, rather then Nothing, which -means "use the default default types of Integer, Double". +The Integer type is simply not available in ghc-prim and ghc-bignum packages (it +is declared in ghc-bignum). So we set the defaulting types to (Just []), meaning +there are no default types, rather than Nothing, which means "use the default +default types of Integer, Double". If you don't do this, attempted defaulting in package ghc-prim causes an actual crash (attempting to look up the Integer type). diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs index da6e71547f..bf6967dccf 100644 --- a/compiler/GHC/Tc/Utils/TcType.hs +++ b/compiler/GHC/Tc/Utils/TcType.hs @@ -77,7 +77,8 @@ module GHC.Tc.Utils.TcType ( pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis, isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy, isFloatingTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy, - isIntegerTy, isBoolTy, isUnitTy, isCharTy, isCallStackTy, isCallStackPred, + isIntegerTy, isNaturalTy, + isBoolTy, isUnitTy, isCharTy, isCallStackTy, isCallStackPred, hasIPPred, isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy, isPredTy, isTyVarClassPred, isTyVarHead, isInsolubleOccursCheck, checkValidClsArgs, hasTyVarHead, @@ -2018,11 +2019,13 @@ isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty isOverloadedTy (FunTy { ft_af = InvisArg }) = True isOverloadedTy _ = False -isFloatTy, isDoubleTy, isIntegerTy, isIntTy, isWordTy, isBoolTy, +isFloatTy, isDoubleTy, isIntegerTy, isNaturalTy, + isIntTy, isWordTy, isBoolTy, isUnitTy, isCharTy, isAnyTy :: Type -> Bool isFloatTy = is_tc floatTyConKey isDoubleTy = is_tc doubleTyConKey isIntegerTy = is_tc integerTyConKey +isNaturalTy = is_tc naturalTyConKey isIntTy = is_tc intTyConKey isWordTy = is_tc wordTyConKey isBoolTy = is_tc boolTyConKey diff --git a/compiler/GHC/Types/Literal.hs b/compiler/GHC/Types/Literal.hs index c57cc2bb97..82807ff00c 100644 --- a/compiler/GHC/Types/Literal.hs +++ b/compiler/GHC/Types/Literal.hs @@ -15,7 +15,7 @@ module GHC.Types.Literal , LitNumType(..) -- ** Creating Literals - , mkLitInt, mkLitIntWrap, mkLitIntWrapC + , mkLitInt, mkLitIntWrap, mkLitIntWrapC, mkLitIntUnchecked , mkLitWord, mkLitWordWrap, mkLitWordWrapC , mkLitInt64, mkLitInt64Wrap , mkLitWord64, mkLitWord64Wrap @@ -53,6 +53,7 @@ module GHC.Types.Literal import GHC.Prelude import GHC.Builtin.Types.Prim +import {-# SOURCE #-} GHC.Builtin.Types import GHC.Builtin.Names import GHC.Core.Type import GHC.Core.TyCon @@ -108,11 +109,9 @@ data Literal = LitChar Char -- ^ @Char#@ - at least 31 bits. Create with -- 'mkLitChar' - | LitNumber !LitNumType !Integer Type + | LitNumber !LitNumType !Integer -- ^ Any numeric literal that can be -- internally represented with an Integer. - -- See Note [Types of LitNumbers] below for the - -- Type field. | LitString !ByteString -- ^ A string-literal: stored and emitted -- UTF-8 encoded, we'll arrange to decode it @@ -150,8 +149,8 @@ data Literal -- | Numeric literal type data LitNumType - = LitNumInteger -- ^ @Integer@ (see Note [Integer literals]) - | LitNumNatural -- ^ @Natural@ (see Note [Natural literals]) + = LitNumInteger -- ^ @Integer@ (see Note [BigNum literals]) + | LitNumNatural -- ^ @Natural@ (see Note [BigNum literals]) | LitNumInt -- ^ @Int#@ - according to target machine | LitNumInt64 -- ^ @Int64#@ - exactly 64 bits | LitNumWord -- ^ @Word#@ - according to target machine @@ -169,26 +168,19 @@ litNumIsSigned nt = case nt of LitNumWord64 -> False {- -Note [Integer literals] -~~~~~~~~~~~~~~~~~~~~~~~ -An Integer literal is represented using, well, an Integer, to make it -easier to write RULEs for them. They also contain the Integer type, so -that e.g. literalType can return the right Type for them. - -They only get converted into real Core, - mkInteger [c1, c2, .., cn] -during the CorePrep phase, although GHC.Iface.Tidy looks ahead at what the -core will be, so that it can see whether it involves CAFs. - -When we initially build an Integer literal, notably when -deserialising it from an interface file (see the Binary instance -below), we don't have convenient access to the mkInteger Id. So we -just use an error thunk, and fill in the real Id when we do tcIfaceLit -in GHC.IfaceToCore. - -Note [Natural literals] -~~~~~~~~~~~~~~~~~~~~~~~ -Similar to Integer literals. +Note [BigNum literals] +~~~~~~~~~~~~~~~~~~~~~~ + +GHC supports 2 kinds of arbitrary precision integers (a.k.a BigNum): + + * Natural: natural represented as a Word# or as a BigNat + + * Integer: integer represented a an Int# or as a BigNat (Integer's + constructors indicate the sign) + +BigNum literal instances are removed from Core during the CorePrep phase. They +are replaced with expression to build them at runtime from machine literals +(Word#, Int#, etc.) or from a list of Word#s. Note [String literals] ~~~~~~~~~~~~~~~~~~~~~~ @@ -223,7 +215,7 @@ instance Binary Literal where put_ bh aj put_ bh mb put_ bh fod - put_ bh (LitNumber nt i _) + put_ bh (LitNumber nt i) = do putByte bh 6 put_ bh nt put_ bh i @@ -253,19 +245,7 @@ instance Binary Literal where 6 -> do nt <- get bh i <- get bh - -- Note [Types of LitNumbers] - let t = case nt of - LitNumInt -> intPrimTy - LitNumInt64 -> int64PrimTy - LitNumWord -> wordPrimTy - LitNumWord64 -> word64PrimTy - -- See Note [Integer literals] - LitNumInteger -> - panic "Evaluated the place holder for mkInteger" - -- and Note [Natural literals] - LitNumNatural -> - panic "Evaluated the place holder for mkNatural" - return (LitNumber nt i t) + return (LitNumber nt i) _ -> do return (LitRubbish) @@ -305,22 +285,22 @@ Int/Word range. -- | Wrap a literal number according to its type wrapLitNumber :: Platform -> Literal -> Literal -wrapLitNumber platform v@(LitNumber nt i t) = case nt of +wrapLitNumber platform v@(LitNumber nt i) = case nt of LitNumInt -> case platformWordSize platform of - PW4 -> LitNumber nt (toInteger (fromIntegral i :: Int32)) t - PW8 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t + PW4 -> LitNumber nt (toInteger (fromIntegral i :: Int32)) + PW8 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) LitNumWord -> case platformWordSize platform of - PW4 -> LitNumber nt (toInteger (fromIntegral i :: Word32)) t - PW8 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t - LitNumInt64 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t - LitNumWord64 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t + PW4 -> LitNumber nt (toInteger (fromIntegral i :: Word32)) + PW8 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) + LitNumInt64 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) + LitNumWord64 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) LitNumInteger -> v LitNumNatural -> v wrapLitNumber _ x = x -- | Create a numeric 'Literal' of the given type -mkLitNumberWrap :: Platform -> LitNumType -> Integer -> Type -> Literal -mkLitNumberWrap platform nt i t = wrapLitNumber platform (LitNumber nt i t) +mkLitNumberWrap :: Platform -> LitNumType -> Integer -> Literal +mkLitNumberWrap platform nt i = wrapLitNumber platform (LitNumber nt i) -- | Check that a given number is in the range of a numeric literal litNumCheckRange :: Platform -> LitNumType -> Integer -> Bool @@ -333,10 +313,10 @@ litNumCheckRange platform nt i = case nt of LitNumInteger -> True -- | Create a numeric 'Literal' of the given type -mkLitNumber :: Platform -> LitNumType -> Integer -> Type -> Literal -mkLitNumber platform nt i t = +mkLitNumber :: Platform -> LitNumType -> Integer -> Literal +mkLitNumber platform nt i = ASSERT2(litNumCheckRange platform nt i, integer i) - (LitNumber nt i t) + (LitNumber nt i) -- | Creates a 'Literal' of type @Int#@ mkLitInt :: Platform -> Integer -> Literal @@ -351,7 +331,7 @@ mkLitIntWrap platform i = wrapLitNumber platform $ mkLitIntUnchecked i -- | Creates a 'Literal' of type @Int#@ without checking its range. mkLitIntUnchecked :: Integer -> Literal -mkLitIntUnchecked i = LitNumber LitNumInt i intPrimTy +mkLitIntUnchecked i = LitNumber LitNumInt i -- | Creates a 'Literal' of type @Int#@, as well as a 'Bool'ean flag indicating -- overflow. That is, if the argument is out of the (target-dependent) range @@ -360,7 +340,7 @@ mkLitIntUnchecked i = LitNumber LitNumInt i intPrimTy mkLitIntWrapC :: Platform -> Integer -> (Literal, Bool) mkLitIntWrapC platform i = (n, i /= i') where - n@(LitNumber _ i' _) = mkLitIntWrap platform i + n@(LitNumber _ i') = mkLitIntWrap platform i -- | Creates a 'Literal' of type @Word#@ mkLitWord :: Platform -> Integer -> Literal @@ -375,7 +355,7 @@ mkLitWordWrap platform i = wrapLitNumber platform $ mkLitWordUnchecked i -- | Creates a 'Literal' of type @Word#@ without checking its range. mkLitWordUnchecked :: Integer -> Literal -mkLitWordUnchecked i = LitNumber LitNumWord i wordPrimTy +mkLitWordUnchecked i = LitNumber LitNumWord i -- | Creates a 'Literal' of type @Word#@, as well as a 'Bool'ean flag indicating -- carry. That is, if the argument is out of the (target-dependent) range @@ -384,7 +364,7 @@ mkLitWordUnchecked i = LitNumber LitNumWord i wordPrimTy mkLitWordWrapC :: Platform -> Integer -> (Literal, Bool) mkLitWordWrapC platform i = (n, i /= i') where - n@(LitNumber _ i' _) = mkLitWordWrap platform i + n@(LitNumber _ i') = mkLitWordWrap platform i -- | Creates a 'Literal' of type @Int64#@ mkLitInt64 :: Integer -> Literal @@ -397,7 +377,7 @@ mkLitInt64Wrap platform i = wrapLitNumber platform $ mkLitInt64Unchecked i -- | Creates a 'Literal' of type @Int64#@ without checking its range. mkLitInt64Unchecked :: Integer -> Literal -mkLitInt64Unchecked i = LitNumber LitNumInt64 i int64PrimTy +mkLitInt64Unchecked i = LitNumber LitNumInt64 i -- | Creates a 'Literal' of type @Word64#@ mkLitWord64 :: Integer -> Literal @@ -410,7 +390,7 @@ mkLitWord64Wrap platform i = wrapLitNumber platform $ mkLitWord64Unchecked i -- | Creates a 'Literal' of type @Word64#@ without checking its range. mkLitWord64Unchecked :: Integer -> Literal -mkLitWord64Unchecked i = LitNumber LitNumWord64 i word64PrimTy +mkLitWord64Unchecked i = LitNumber LitNumWord64 i -- | Creates a 'Literal' of type @Float#@ mkLitFloat :: Rational -> Literal @@ -430,12 +410,12 @@ mkLitString :: String -> Literal -- stored UTF-8 encoded mkLitString s = LitString (bytesFS $ mkFastString s) -mkLitInteger :: Integer -> Type -> Literal -mkLitInteger x ty = LitNumber LitNumInteger x ty +mkLitInteger :: Integer -> Literal +mkLitInteger x = LitNumber LitNumInteger x -mkLitNatural :: Integer -> Type -> Literal -mkLitNatural x ty = ASSERT2( inNaturalRange x, integer x ) - (LitNumber LitNumNatural x ty) +mkLitNatural :: Integer -> Literal +mkLitNatural x = ASSERT2( inNaturalRange x, integer x ) + (LitNumber LitNumNatural x) inNaturalRange :: Integer -> Bool inNaturalRange x = x >= 0 @@ -451,10 +431,10 @@ inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR -- | Tests whether the literal represents a zero of whatever type it is isZeroLit :: Literal -> Bool -isZeroLit (LitNumber _ 0 _) = True -isZeroLit (LitFloat 0) = True -isZeroLit (LitDouble 0) = True -isZeroLit _ = False +isZeroLit (LitNumber _ 0) = True +isZeroLit (LitFloat 0) = True +isZeroLit (LitDouble 0) = True +isZeroLit _ = False -- | Returns the 'Integer' contained in the 'Literal', for when that makes -- sense, i.e. for 'Char', 'Int', 'Word', 'LitInteger' and 'LitNatural'. @@ -467,7 +447,7 @@ litValue l = case isLitValue_maybe l of -- sense, i.e. for 'Char' and numbers. isLitValue_maybe :: Literal -> Maybe Integer isLitValue_maybe (LitChar c) = Just $ toInteger $ ord c -isLitValue_maybe (LitNumber _ i _) = Just i +isLitValue_maybe (LitNumber _ i) = Just i isLitValue_maybe _ = Nothing -- | Apply a function to the 'Integer' contained in the 'Literal', for when that @@ -478,8 +458,7 @@ isLitValue_maybe _ = Nothing mapLitValue :: Platform -> (Integer -> Integer) -> Literal -> Literal mapLitValue _ f (LitChar c) = mkLitChar (fchar c) where fchar = chr . fromInteger . f . toInteger . ord -mapLitValue platform f (LitNumber nt i t) = wrapLitNumber platform - (LitNumber nt (f i) t) +mapLitValue platform f (LitNumber nt i) = wrapLitNumber platform (LitNumber nt (f i)) mapLitValue _ _ l = pprPanic "mapLitValue" (ppr l) -- | Indicate if the `Literal` contains an 'Integer' value, e.g. 'Char', @@ -500,7 +479,7 @@ narrow8IntLit, narrow16IntLit, narrow32IntLit, :: Literal -> Literal word2IntLit, int2WordLit :: Platform -> Literal -> Literal -word2IntLit platform (LitNumber LitNumWord w _) +word2IntLit platform (LitNumber LitNumWord w) -- Map Word range [max_int+1, max_word] -- to Int range [min_int , -1] -- Range [0,max_int] has the same representation with both Int and Word @@ -508,7 +487,7 @@ word2IntLit platform (LitNumber LitNumWord w _) | otherwise = mkLitInt platform w word2IntLit _ l = pprPanic "word2IntLit" (ppr l) -int2WordLit platform (LitNumber LitNumInt i _) +int2WordLit platform (LitNumber LitNumInt i) -- Map Int range [min_int , -1] -- to Word range [max_int+1, max_word] -- Range [0,max_int] has the same representation with both Int and Word @@ -518,8 +497,8 @@ int2WordLit _ l = pprPanic "int2WordLit" (ppr l) -- | Narrow a literal number (unchecked result range) narrowLit :: forall a. Integral a => Proxy a -> Literal -> Literal -narrowLit _ (LitNumber nt i t) = LitNumber nt (toInteger (fromInteger i :: a)) t -narrowLit _ l = pprPanic "narrowLit" (ppr l) +narrowLit _ (LitNumber nt i) = LitNumber nt (toInteger (fromInteger i :: a)) +narrowLit _ l = pprPanic "narrowLit" (ppr l) narrow8IntLit = narrowLit (Proxy :: Proxy Int8) narrow16IntLit = narrowLit (Proxy :: Proxy Int16) @@ -530,17 +509,17 @@ narrow32WordLit = narrowLit (Proxy :: Proxy Word32) char2IntLit (LitChar c) = mkLitIntUnchecked (toInteger (ord c)) char2IntLit l = pprPanic "char2IntLit" (ppr l) -int2CharLit (LitNumber _ i _) = LitChar (chr (fromInteger i)) +int2CharLit (LitNumber _ i) = LitChar (chr (fromInteger i)) int2CharLit l = pprPanic "int2CharLit" (ppr l) float2IntLit (LitFloat f) = mkLitIntUnchecked (truncate f) float2IntLit l = pprPanic "float2IntLit" (ppr l) -int2FloatLit (LitNumber _ i _) = LitFloat (fromInteger i) +int2FloatLit (LitNumber _ i) = LitFloat (fromInteger i) int2FloatLit l = pprPanic "int2FloatLit" (ppr l) double2IntLit (LitDouble f) = mkLitIntUnchecked (truncate f) double2IntLit l = pprPanic "double2IntLit" (ppr l) -int2DoubleLit (LitNumber _ i _) = LitDouble (fromInteger i) +int2DoubleLit (LitNumber _ i) = LitDouble (fromInteger i) int2DoubleLit l = pprPanic "int2DoubleLit" (ppr l) float2DoubleLit (LitFloat f) = LitDouble f @@ -595,8 +574,8 @@ rubbishLit = LitRubbish -- user code. One approach to this is described in #8472. litIsTrivial :: Literal -> Bool -- c.f. GHC.Core.Utils.exprIsTrivial -litIsTrivial (LitString _) = False -litIsTrivial (LitNumber nt _ _) = case nt of +litIsTrivial (LitString _) = False +litIsTrivial (LitNumber nt _) = case nt of LitNumInteger -> False LitNumNatural -> False LitNumInt -> True @@ -609,7 +588,7 @@ litIsTrivial _ = True litIsDupable :: Platform -> Literal -> Bool -- c.f. GHC.Core.Utils.exprIsDupable litIsDupable platform x = case x of - (LitNumber nt i _) -> case nt of + (LitNumber nt i) -> case nt of LitNumInteger -> platformInIntRange platform i LitNumNatural -> platformInWordRange platform i LitNumInt -> True @@ -620,12 +599,12 @@ litIsDupable platform x = case x of _ -> True litFitsInChar :: Literal -> Bool -litFitsInChar (LitNumber _ i _) = i >= toInteger (ord minBound) - && i <= toInteger (ord maxBound) -litFitsInChar _ = False +litFitsInChar (LitNumber _ i) = i >= toInteger (ord minBound) + && i <= toInteger (ord maxBound) +litFitsInChar _ = False litIsLifted :: Literal -> Bool -litIsLifted (LitNumber nt _ _) = case nt of +litIsLifted (LitNumber nt _) = case nt of LitNumInteger -> True LitNumNatural -> True LitNumInt -> False @@ -637,26 +616,6 @@ litIsLifted _ = False {- Types ~~~~~ - -Note [Types of LitNumbers] -~~~~~~~~~~~~~~~~~~~~~~~~~~ - -A LitNumber's type is always known from its LitNumType: - - LitNumInteger -> Integer - LitNumNatural -> Natural - LitNumInt -> Int# (intPrimTy) - LitNumInt64 -> Int64# (int64PrimTy) - LitNumWord -> Word# (wordPrimTy) - LitNumWord64 -> Word64# (word64PrimTy) - -The reason why we have a Type field is because Integer and Natural types live -outside of GHC (in the libraries), so we have to get the actual Type via -lookupTyCon, tcIfaceTyConByName etc. that's too inconvenient in the call sites -of literalType, so we do that when creating these literals, and literalType -simply reads the field. - -(But see also Note [Integer literals] and Note [Natural literals]) -} -- | Find the Haskell 'Type' the literal occupies @@ -667,7 +626,13 @@ literalType (LitString _) = addrPrimTy literalType (LitFloat _) = floatPrimTy literalType (LitDouble _) = doublePrimTy literalType (LitLabel _ _ _) = addrPrimTy -literalType (LitNumber _ _ t) = t -- Note [Types of LitNumbers] +literalType (LitNumber lt _) = case lt of + LitNumInteger -> integerTy + LitNumNatural -> naturalTy + LitNumInt -> intPrimTy + LitNumInt64 -> int64PrimTy + LitNumWord -> wordPrimTy + LitNumWord64 -> word64PrimTy literalType (LitRubbish) = mkForAllTy a Inferred (mkTyVarTy a) where a = alphaTyVarUnliftedRep @@ -703,7 +668,7 @@ cmpLit (LitNullAddr) (LitNullAddr) = EQ cmpLit (LitFloat a) (LitFloat b) = a `compare` b cmpLit (LitDouble a) (LitDouble b) = a `compare` b cmpLit (LitLabel a _ _) (LitLabel b _ _) = a `compare` b -cmpLit (LitNumber nt1 a _) (LitNumber nt2 b _) +cmpLit (LitNumber nt1 a) (LitNumber nt2 b) | nt1 == nt2 = a `compare` b | otherwise = nt1 `compare` nt2 cmpLit (LitRubbish) (LitRubbish) = EQ @@ -733,7 +698,7 @@ pprLiteral _ (LitString s) = pprHsBytes s pprLiteral _ (LitNullAddr) = text "__NULL" pprLiteral _ (LitFloat f) = float (fromRat f) <> primFloatSuffix pprLiteral _ (LitDouble d) = double (fromRat d) <> primDoubleSuffix -pprLiteral add_par (LitNumber nt i _) +pprLiteral add_par (LitNumber nt i) = case nt of LitNumInteger -> pprIntegerVal add_par i LitNumNatural -> pprIntegerVal add_par i diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs index ac1b220918..aa1318ad5d 100644 --- a/compiler/GHC/Unit/State.hs +++ b/compiler/GHC/Unit/State.hs @@ -954,26 +954,12 @@ sortByPreference prec_map = sortBy (flip (compareByPreference prec_map)) -- Pursuant to #12518, we could change this policy to, for example, remove -- the version preference, meaning that we would always prefer the units -- in later unit database. --- --- Instead, we use that preference based policy only when one of the packages --- is integer-gmp and the other is integer-simple. --- This currently only happens when we're looking up which concrete --- package to use in place of @integer-wired-in@ and that two different --- package databases supply a different integer library. For more about --- the fake @integer-wired-in@ package, see Note [The integer library] --- in the @GHC.Builtin.Names@ module. compareByPreference :: UnitPrecedenceMap -> UnitInfo -> UnitInfo -> Ordering compareByPreference prec_map pkg pkg' - | Just prec <- Map.lookup (unitId pkg) prec_map - , Just prec' <- Map.lookup (unitId pkg') prec_map - , differentIntegerPkgs pkg pkg' - = compare prec prec' - - | otherwise = case comparing unitPackageVersion pkg pkg' of GT -> GT EQ | Just prec <- Map.lookup (unitId pkg) prec_map @@ -985,12 +971,6 @@ compareByPreference prec_map pkg pkg' -> EQ LT -> LT - where isIntegerPkg p = unitPackageNameString p `elem` - ["integer-simple", "integer-gmp"] - differentIntegerPkgs p p' = - isIntegerPkg p && isIntegerPkg p' && - (unitPackageName p /= unitPackageName p') - comparing :: Ord a => (t -> a) -> t -> t -> Ordering comparing f a b = f a `compare` f b @@ -1054,10 +1034,6 @@ findWiredInUnits printer prec_map pkgs vis_map = do -- in Note [Wired-in units] in GHC.Unit.Module let matches :: UnitInfo -> UnitId -> Bool - pc `matches` pid - -- See Note [The integer library] in GHC.Builtin.Names - | pid == integerUnitId - = unitPackageNameString pc `elem` ["integer-gmp", "integer-simple"] pc `matches` pid = unitPackageName pc == PackageName (unitIdFS pid) -- find which package corresponds to each wired-in package diff --git a/compiler/GHC/Unit/Types.hs b/compiler/GHC/Unit/Types.hs index ffe9b38bf9..dace82c759 100644 --- a/compiler/GHC/Unit/Types.hs +++ b/compiler/GHC/Unit/Types.hs @@ -55,7 +55,7 @@ module GHC.Unit.Types -- * Wired-in units , primUnitId - , integerUnitId + , bignumUnitId , baseUnitId , rtsUnitId , thUnitId @@ -64,7 +64,7 @@ module GHC.Unit.Types , interactiveUnitId , primUnit - , integerUnit + , bignumUnit , baseUnit , rtsUnit , thUnit @@ -603,19 +603,16 @@ the symbols in the object files have the unversioned unit id in their name. Make sure you change 'GHC.Unit.State.findWiredInUnits' if you add an entry here. -For `integer-gmp`/`integer-simple` we also change the base name to -`integer-wired-in`, but this is fundamentally no different. -See Note [The integer library] in "GHC.Builtin.Names". -} -integerUnitId, primUnitId, baseUnitId, rtsUnitId, +bignumUnitId, primUnitId, baseUnitId, rtsUnitId, thUnitId, mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId -integerUnit, primUnit, baseUnit, rtsUnit, +bignumUnit, primUnit, baseUnit, rtsUnit, thUnit, mainUnit, thisGhcUnit, interactiveUnit :: Unit primUnitId = UnitId (fsLit "ghc-prim") -integerUnitId = UnitId (fsLit "integer-wired-in") +bignumUnitId = UnitId (fsLit "ghc-bignum") baseUnitId = UnitId (fsLit "base") rtsUnitId = UnitId (fsLit "rts") thisGhcUnitId = UnitId (fsLit "ghc") @@ -624,7 +621,7 @@ thUnitId = UnitId (fsLit "template-haskell") thUnit = RealUnit (Definite thUnitId) primUnit = RealUnit (Definite primUnitId) -integerUnit = RealUnit (Definite integerUnitId) +bignumUnit = RealUnit (Definite bignumUnitId) baseUnit = RealUnit (Definite baseUnitId) rtsUnit = RealUnit (Definite rtsUnitId) thisGhcUnit = RealUnit (Definite thisGhcUnitId) @@ -642,7 +639,7 @@ isInteractiveModule mod = moduleUnit mod == interactiveUnit wiredInUnitIds :: [UnitId] wiredInUnitIds = [ primUnitId - , integerUnitId + , bignumUnitId , baseUnitId , rtsUnitId , thUnitId diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 9ef9245a9a..494725a0b6 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -48,16 +48,6 @@ Flag terminfo Default: True Manual: True -Flag integer-simple - Description: Use integer-simple - Manual: True - Default: False - -Flag integer-gmp - Description: Use integer-gmp - Manual: True - Default: False - Flag dynamic-system-linker Description: The system can load dynamic code. This is not the case for musl. Default: True @@ -102,20 +92,6 @@ Library CPP-Options: -DHAVE_INTERNAL_INTERPRETER Include-Dirs: ../rts/dist/build @FFIIncludeDir@ - -- sanity-check to ensure not more than one integer flag is set - if flag(integer-gmp) && flag(integer-simple) - build-depends: invalid-cabal-flag-settings<0 - - -- gmp internals are used by the GHCi debugger if available - if flag(integer-gmp) - CPP-Options: -DINTEGER_GMP - build-depends: integer-gmp >= 1.0.2 - - -- simple internals are used by the GHCi debugger if available - if flag(integer-simple) - CPP-Options: -DINTEGER_SIMPLE - build-depends: integer-simple >= 0.1.1.1 - -- if no dynamic system linker is available, don't try DLLs. if flag(dynamic-system-linker) CPP-Options: -DCAN_LOAD_DLL |