Simon Peyton Jones pushed to branch wip/spj-reinstallable-base at Glasgow Haskell Compiler / GHC Commits: 809c39ee by Simon Peyton Jones at 2026-04-02T17:37:00+01:00 More....[skip ci] Lots of Names have moved to new mechanism BuiltinRules had KnownKeyNameKeys Start on updating RdrName but incomplete, hence skip ci - - - - - 30 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/Core.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/Name.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/Unique/FM.hs - libraries/base/src/Data/Functor/Classes.hs - libraries/base/src/GHC/KnownKeyNames.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/BigNat.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/BigNat.hs-boot - libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs-boot - libraries/ghc-internal/src/GHC/Internal/Bignum/Natural.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Natural.hs-boot - libraries/ghc-internal/src/GHC/Internal/CString.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Const.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Identity.hs - libraries/ghc-internal/src/GHC/Internal/Data/Ord.hs - libraries/ghc-internal/src/GHC/Internal/Data/Typeable/Internal.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding.hs - libraries/ghc-internal/src/GHC/Internal/Magic.hs - libraries/ghc-internal/src/GHC/Internal/Read.hs - libraries/ghc-internal/src/GHC/Internal/Unsafe/Coerce.hs Changes: ===================================== compiler/GHC/Builtin/Names.hs ===================================== @@ -222,7 +222,7 @@ basicKnownKeyTable , (mkTcOcc "Eq", eqClassKey) , (mkVarOcc "==", eqClassOpKey) - -- Class Num + -- Numeric operations , (mkTcOcc "Num", numClassKey) , (mkVarOcc "-", minusClassOpKey) , (mkVarOcc "negate", negateClassOpKey) @@ -230,6 +230,8 @@ basicKnownKeyTable , (mkVarOcc "fromRational", fromRationalClassOpKey) , (mkVarOcc "mkRationalBase2", mkRationalBase2IdKey) , (mkVarOcc "mkRationalBase10", mkRationalBase10IdKey) + , (mkVarOcc "divInt#", divIntIdKey) + , (mkVarOcc "modInt#", modIntIdKey) -- Class Functor , (mkTcOcc "Functor", functorClassKey) @@ -286,6 +288,79 @@ basicKnownKeyTable , (mkVarOcc "bindIO", bindIOIdKey) , (mkVarOcc "returnIO", returnIOIdKey) , (mkVarOcc "print", printIdKey) + + -- Known-key names that have BuiltinRules in ConstantFold + , (mkVarOcc "unpackFoldrCString#", unpackCStringFoldrIdKey) + , (mkVarOcc "unpackFoldrCStringUtf8#", unpackCStringFoldrUtf8IdKey) + , (mkVarOcc "unpackAppendCString#", unpackCStringAppendIdKey) + , (mkVarOcc "unpackAppendCStringUtf8#", unpackCStringAppendUtf8IdKey) + , (mkVarOcc "cstringLength#", cstringLengthIdKey) + + , (mkVarOcc "eqString", eqStringIdKey) + , (mkVarOcc "inline", inlineIdKey) + + , (mkVarOcc "unsafeEqualityProof", unsafeEqualityProofIdKey) + , (mkTcOcc "UnsafeEquality", unsafeEqualityTyConKey) + , (mkDataOcc "UnsafeRefl", unsafeReflDataConKey) + + -- Bignum operations, have BuiltinRules in ConstantFold + , (mkVarOcc "bigNatEq#", bignatEqIdKey) + , (mkVarOcc "bigNatCompare", bignatCompareIdKey) + , (mkVarOcc "bigNatCompareWord#", bignatCompareWordIdKey) + , (mkVarOcc "naturalToWord#", naturalToWordIdKey) + , (mkVarOcc "naturalPopCount#", naturalPopCountIdKey) + , (mkVarOcc "naturalShiftR#", naturalShiftRIdKey) + , (mkVarOcc "naturalShiftL#", naturalShiftLIdKey) + , (mkVarOcc "naturalAdd", naturalAddIdKey) + , (mkVarOcc "naturalSub", naturalSubIdKey) + , (mkVarOcc "naturalSubThrow", naturalSubThrowIdKey) + , (mkVarOcc "naturalSubUnsafe", naturalSubUnsafeIdKey) + , (mkVarOcc "naturalMul", naturalMulIdKey) + , (mkVarOcc "naturalQuotRem#", naturalQuotRemIdKey) + , (mkVarOcc "naturalQuot", naturalQuotIdKey) + , (mkVarOcc "naturalRem", naturalRemIdKey) + , (mkVarOcc "naturalAnd", naturalAndIdKey) + , (mkVarOcc "naturalOr", naturalOrIdKey) + , (mkVarOcc "naturalXor", naturalXorIdKey) + , (mkVarOcc "naturalTestBit#", naturalTestBitIdKey) + , (mkVarOcc "naturalBit#", naturalBitIdKey) + , (mkVarOcc "naturalGcd", naturalGcdIdKey) + , (mkVarOcc "naturalLcm", naturalLcmIdKey) + , (mkVarOcc "integerFromNatural", integerFromNaturalIdKey) + , (mkVarOcc "integerToNaturalClamp", integerToNaturalClampIdKey) + , (mkVarOcc "integerToNaturalThrow", integerToNaturalThrowIdKey) + , (mkVarOcc "integerToNatural", integerToNaturalIdKey) + , (mkVarOcc "integerToWord#", integerToWordIdKey) + , (mkVarOcc "integerToInt#", integerToIntIdKey) + , (mkVarOcc "integerToWord64#", integerToWord64IdKey) + , (mkVarOcc "integerToInt64#", integerToInt64IdKey) + , (mkVarOcc "integerFromWord#", integerFromWordIdKey) + , (mkVarOcc "integerFromWord64#", integerFromWord64IdKey) + , (mkVarOcc "integerFromInt64#", integerFromInt64IdKey) + , (mkVarOcc "integerAdd", integerAddIdKey) + , (mkVarOcc "integerMul", integerMulIdKey) + , (mkVarOcc "integerSub", integerSubIdKey) + , (mkVarOcc "integerNegate", integerNegateIdKey) + , (mkVarOcc "integerAbs", integerAbsIdKey) + , (mkVarOcc "integerPopCount#", integerPopCountIdKey) + , (mkVarOcc "integerQuot", integerQuotIdKey) + , (mkVarOcc "integerRem", integerRemIdKey) + , (mkVarOcc "integerDiv", integerDivIdKey) + , (mkVarOcc "integerMod", integerModIdKey) + , (mkVarOcc "integerDivMod#", integerDivModIdKey) + , (mkVarOcc "integerQuotRem#", integerQuotRemIdKey) + , (mkVarOcc "integerEncodeFloat#", integerEncodeFloatIdKey) + , (mkVarOcc "integerEncodeDouble#", integerEncodeDoubleIdKey) + , (mkVarOcc "integerGcd", integerGcdIdKey) + , (mkVarOcc "integerLcm", integerLcmIdKey) + , (mkVarOcc "integerAnd", integerAndIdKey) + , (mkVarOcc "integerOr", integerOrIdKey) + , (mkVarOcc "integerXor", integerXorIdKey) + , (mkVarOcc "integerComplement", integerComplementIdKey) + , (mkVarOcc "integerBit#", integerBitIdKey) + , (mkVarOcc "integerTestBit#", integerTestBitIdKey) + , (mkVarOcc "integerShiftL#", integerShiftLIdKey) + , (mkVarOcc "integerShiftR#", integerShiftRIdKey) ] basicKnownKeyNames :: [Name] -- See Note [Known-key names] @@ -353,9 +428,6 @@ basicKnownKeyNames toIntegerName, toRationalName, fromIntegralName, realToFracName, - -- Int# stuff - divIntName, modIntName, - -- String stuff fromStringName, @@ -370,9 +442,6 @@ basicKnownKeyNames bindMName, thenMName, returnMName, - -- Ix stuff - ixClassName, - -- Read stuff readClassName, @@ -384,9 +453,6 @@ basicKnownKeyNames -- Strings and lists unpackCStringName, unpackCStringUtf8Name, - unpackCStringAppendName, unpackCStringAppendUtf8Name, - unpackCStringFoldrName, unpackCStringFoldrUtf8Name, - cstringLengthName, -- Non-empty lists nonEmptyTyConName, @@ -401,71 +467,12 @@ basicKnownKeyNames jsvalTyConName, -- Others - otherwiseIdName, inlineIdName, - eqStringName, assertName, + otherwiseIdName, + assertName, assertErrorName, traceName, printName, dollarName, - -- ghc-bignum - integerFromNaturalName, - integerToNaturalClampName, - integerToNaturalThrowName, - integerToNaturalName, - integerToWordName, - integerToIntName, - integerToWord64Name, - integerToInt64Name, - integerFromWordName, - integerFromWord64Name, - integerFromInt64Name, - integerAddName, - integerMulName, - integerSubName, - integerNegateName, - integerAbsName, - integerPopCountName, - integerQuotName, - integerRemName, - integerDivName, - integerModName, - integerDivModName, - integerQuotRemName, - integerEncodeFloatName, - integerEncodeDoubleName, - integerGcdName, - integerLcmName, - integerAndName, - integerOrName, - integerXorName, - integerComplementName, - integerBitName, - integerTestBitName, - integerShiftLName, - integerShiftRName, - - naturalToWordName, - naturalPopCountName, - naturalShiftRName, - naturalShiftLName, - naturalAddName, - naturalSubName, - naturalSubThrowName, - naturalSubUnsafeName, - naturalMulName, - naturalQuotRemName, - naturalQuotName, - naturalRemName, - naturalAndName, - naturalOrName, - naturalXorName, - naturalTestBitName, - naturalBitName, - naturalGcdName, - naturalLcmName, - - bignatEqName, - -- Float/Double integerToFloatName, integerToDoubleName, @@ -535,9 +542,6 @@ basicKnownKeyNames , unsatisfiableIdName -- Unsafe coercion proofs - , unsafeEqualityProofName - , unsafeEqualityTyConName - , unsafeReflDataConName , unsafeCoercePrimName , unsafeUnpackJSStringUtf8ShShName @@ -1020,31 +1024,10 @@ metaDataDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "MetaData") metaData metaConsDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "MetaCons") metaConsDataConKey metaSelDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "MetaSel") metaSelDataConKey --- Primitive Int -divIntName, modIntName :: Name -divIntName = varQual gHC_CLASSES (fsLit "divInt#") divIntIdKey -modIntName = varQual gHC_CLASSES (fsLit "modInt#") modIntIdKey - -- Base strings Strings -unpackCStringName, unpackCStringFoldrName, - unpackCStringUtf8Name, unpackCStringFoldrUtf8Name, - unpackCStringAppendName, unpackCStringAppendUtf8Name, - eqStringName, cstringLengthName :: Name -cstringLengthName = varQual gHC_CSTRING (fsLit "cstringLength#") cstringLengthIdKey -eqStringName = varQual gHC_INTERNAL_BASE (fsLit "eqString") eqStringIdKey - +unpackCStringName, unpackCStringUtf8Name :: Name unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey -unpackCStringAppendName = varQual gHC_CSTRING (fsLit "unpackAppendCString#") unpackCStringAppendIdKey -unpackCStringFoldrName = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey - unpackCStringUtf8Name = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey -unpackCStringAppendUtf8Name = varQual gHC_CSTRING (fsLit "unpackAppendCStringUtf8#") unpackCStringAppendUtf8IdKey -unpackCStringFoldrUtf8Name = varQual gHC_CSTRING (fsLit "unpackFoldrCStringUtf8#") unpackCStringFoldrUtf8IdKey - - --- The 'inline' function -inlineIdName :: Name -inlineIdName = varQual gHC_MAGIC (fsLit "inline") inlineIdKey -- Base classes (Eq, Ord, Functor) fmapName, geName, functorClassName :: Name @@ -1108,134 +1091,11 @@ fromStringName = varQual gHC_INTERNAL_DATA_STRING (fsLit "fromString") fromSt negateName :: Name negateName = varQual gHC_INTERNAL_NUM (fsLit "negate") negateClassOpKey ---------------------------------- --- ghc-bignum ---------------------------------- -integerFromNaturalName - , integerToNaturalClampName - , integerToNaturalThrowName - , integerToNaturalName - , integerToWordName - , integerToIntName - , integerToWord64Name - , integerToInt64Name - , integerFromWordName - , integerFromWord64Name - , integerFromInt64Name - , integerAddName - , integerMulName - , integerSubName - , integerNegateName - , integerAbsName - , integerPopCountName - , integerQuotName - , integerRemName - , integerDivName - , integerModName - , integerDivModName - , integerQuotRemName - , integerEncodeFloatName - , integerEncodeDoubleName - , integerGcdName - , integerLcmName - , integerAndName - , integerOrName - , integerXorName - , integerComplementName - , integerBitName - , integerTestBitName - , integerShiftLName - , integerShiftRName - , naturalToWordName - , naturalPopCountName - , naturalShiftRName - , naturalShiftLName - , naturalAddName - , naturalSubName - , naturalSubThrowName - , naturalSubUnsafeName - , naturalMulName - , naturalQuotRemName - , naturalQuotName - , naturalRemName - , naturalAndName - , naturalOrName - , naturalXorName - , naturalTestBitName - , naturalBitName - , naturalGcdName - , naturalLcmName - , bignatEqName - , bignatCompareName - , bignatCompareWordName - :: Name - bnbVarQual, bnnVarQual, bniVarQual :: String -> Unique -> Name bnbVarQual str key = varQual gHC_INTERNAL_NUM_BIGNAT (fsLit str) key bnnVarQual str key = varQual gHC_INTERNAL_NUM_NATURAL (fsLit str) key bniVarQual str key = varQual gHC_INTERNAL_NUM_INTEGER (fsLit str) key --- Types and DataCons -bignatEqName = bnbVarQual "bigNatEq#" bignatEqIdKey -bignatCompareName = bnbVarQual "bigNatCompare" bignatCompareIdKey -bignatCompareWordName = bnbVarQual "bigNatCompareWord#" bignatCompareWordIdKey - -naturalToWordName = bnnVarQual "naturalToWord#" naturalToWordIdKey -naturalPopCountName = bnnVarQual "naturalPopCount#" naturalPopCountIdKey -naturalShiftRName = bnnVarQual "naturalShiftR#" naturalShiftRIdKey -naturalShiftLName = bnnVarQual "naturalShiftL#" naturalShiftLIdKey -naturalAddName = bnnVarQual "naturalAdd" naturalAddIdKey -naturalSubName = bnnVarQual "naturalSub" naturalSubIdKey -naturalSubThrowName = bnnVarQual "naturalSubThrow" naturalSubThrowIdKey -naturalSubUnsafeName = bnnVarQual "naturalSubUnsafe" naturalSubUnsafeIdKey -naturalMulName = bnnVarQual "naturalMul" naturalMulIdKey -naturalQuotRemName = bnnVarQual "naturalQuotRem#" naturalQuotRemIdKey -naturalQuotName = bnnVarQual "naturalQuot" naturalQuotIdKey -naturalRemName = bnnVarQual "naturalRem" naturalRemIdKey -naturalAndName = bnnVarQual "naturalAnd" naturalAndIdKey -naturalOrName = bnnVarQual "naturalOr" naturalOrIdKey -naturalXorName = bnnVarQual "naturalXor" naturalXorIdKey -naturalTestBitName = bnnVarQual "naturalTestBit#" naturalTestBitIdKey -naturalBitName = bnnVarQual "naturalBit#" naturalBitIdKey -naturalGcdName = bnnVarQual "naturalGcd" naturalGcdIdKey -naturalLcmName = bnnVarQual "naturalLcm" naturalLcmIdKey - -integerFromNaturalName = bniVarQual "integerFromNatural" integerFromNaturalIdKey -integerToNaturalClampName = bniVarQual "integerToNaturalClamp" integerToNaturalClampIdKey -integerToNaturalThrowName = bniVarQual "integerToNaturalThrow" integerToNaturalThrowIdKey -integerToNaturalName = bniVarQual "integerToNatural" integerToNaturalIdKey -integerToWordName = bniVarQual "integerToWord#" integerToWordIdKey -integerToIntName = bniVarQual "integerToInt#" integerToIntIdKey -integerToWord64Name = bniVarQual "integerToWord64#" integerToWord64IdKey -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 -integerAbsName = bniVarQual "integerAbs" integerAbsIdKey -integerPopCountName = bniVarQual "integerPopCount#" integerPopCountIdKey -integerQuotName = bniVarQual "integerQuot" integerQuotIdKey -integerRemName = bniVarQual "integerRem" integerRemIdKey -integerDivName = bniVarQual "integerDiv" integerDivIdKey -integerModName = bniVarQual "integerMod" integerModIdKey -integerDivModName = bniVarQual "integerDivMod#" integerDivModIdKey -integerQuotRemName = bniVarQual "integerQuotRem#" integerQuotRemIdKey -integerEncodeFloatName = bniVarQual "integerEncodeFloat#" integerEncodeFloatIdKey -integerEncodeDoubleName = bniVarQual "integerEncodeDouble#" integerEncodeDoubleIdKey -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 -integerTestBitName = bniVarQual "integerTestBit#" integerTestBitIdKey -integerShiftLName = bniVarQual "integerShiftL#" integerShiftLIdKey -integerShiftRName = bniVarQual "integerShiftR#" integerShiftRIdKey - --------------------------------- @@ -1262,10 +1122,6 @@ integerToDoubleName = varQual gHC_INTERNAL_FLOAT (fsLit "integerToDouble#") int rationalToFloatName = varQual gHC_INTERNAL_FLOAT (fsLit "rationalToFloat#") rationalToFloatIdKey rationalToDoubleName = varQual gHC_INTERNAL_FLOAT (fsLit "rationalToDouble#") rationalToDoubleIdKey --- Class Ix -ixClassName :: Name -ixClassName = clsQual gHC_INTERNAL_IX (fsLit "Ix") ixClassKey - -- Typeable representation types trModuleTyConName , trModuleDataConName @@ -1384,11 +1240,7 @@ unsatisfiableIdName = varQual gHC_INTERNAL_TYPEERROR (fsLit "unsatisfiable") unsatisfiableIdNameKey -- Unsafe coercion proofs -unsafeEqualityProofName, unsafeEqualityTyConName, unsafeCoercePrimName, - unsafeReflDataConName :: Name -unsafeEqualityProofName = varQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "unsafeEqualityProof") unsafeEqualityProofIdKey -unsafeEqualityTyConName = tcQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "UnsafeEquality") unsafeEqualityTyConKey -unsafeReflDataConName = dcQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "UnsafeRefl") unsafeReflDataConKey +unsafeCoercePrimName:: Name unsafeCoercePrimName = varQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "unsafeCoerce#") unsafeCoercePrimIdKey -- Dynamic ===================================== compiler/GHC/Core.hs ===================================== @@ -88,7 +88,7 @@ module GHC.Core ( RuleName, RuleFun, IdUnfoldingFun, InScopeEnv(..), RuleOpts, -- ** Operations on 'CoreRule's - ruleArity, ruleName, ruleIdName, ruleActivation, + ruleArity, ruleName, ruleKey, ruleActivation, setRuleIdName, ruleModule, isBuiltinRule, isLocalRule, isAutoRule, ) where @@ -96,19 +96,21 @@ module GHC.Core ( import GHC.Prelude import GHC.Platform -import GHC.Types.Var.Env( InScopeSet ) -import GHC.Types.Var import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.Rules.Config ( RuleOpts ) +import GHC.Core.DataCon +import GHC.Unit.Module + import GHC.Types.InlinePragma import GHC.Types.Name import GHC.Types.Name.Set +import GHC.Types.Var.Env( InScopeSet ) +import GHC.Types.Var import GHC.Types.Literal import GHC.Types.Tickish -import GHC.Core.DataCon -import GHC.Unit.Module import GHC.Types.Basic +import GHC.Types.Unique import GHC.Types.Unique.Set import GHC.Utils.Binary @@ -1508,14 +1510,17 @@ data CoreRule -- A built-in rule is always visible (there is no such thing as -- an orphan built-in rule.) | BuiltinRule { - ru_name :: RuleName, -- ^ As above - ru_fn :: Name, -- ^ As above + ru_name :: RuleName, -- ^ As above + ru_key :: KnownKeyNameKey, -- ^ Identifies the function + -- Not its Name because BuiltInRules are constants + -- and GHC doesn't know the defining module + -- See Note [Overview of known-key names] ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' consumes, -- if it fires, including type arguments ru_try :: RuleFun -- ^ This function does the rewrite. It given too many -- arguments, it simply discards them; the returned 'CoreExpr' - -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args + -- is just the rewrite of function applied to the first 'ru_nargs' args } -- See Note [Extra args in the target] in GHC.Core.Rules @@ -1538,7 +1543,7 @@ isAutoRule :: CoreRule -> Bool isAutoRule (BuiltinRule {}) = False isAutoRule (Rule { ru_auto = is_auto }) = is_auto --- | The number of arguments the 'ru_fn' must be applied +-- | The number of arguments the function must be applied -- to before the rule can match on it ruleArity :: CoreRule -> FullArgCount ruleArity (BuiltinRule {ru_nargs = n}) = n @@ -1555,17 +1560,21 @@ ruleActivation :: CoreRule -> ActivationGhc ruleActivation (BuiltinRule { }) = AlwaysActive ruleActivation (Rule { ru_act = act }) = act --- | The 'Name' of the 'GHC.Types.Id.Id' at the head of the rule left hand side -ruleIdName :: CoreRule -> Name -ruleIdName = ru_fn - isLocalRule :: CoreRule -> Bool isLocalRule (BuiltinRule {}) = False isLocalRule (Rule { ru_local = is_local }) = is_local +-- | The 'Unique' of the function at the head of the rule left hand side +ruleKey :: CoreRule -> Unique +ruleKey (Rule { ru_fn = name }) = nameUnique name +ruleKey (BuiltinRule { ru_key = key }) = key + -- | Set the 'Name' of the 'GHC.Types.Id.Id' at the head of the rule left hand side setRuleIdName :: Name -> CoreRule -> CoreRule -setRuleIdName nm ru = ru { ru_fn = nm } +setRuleIdName nm rule + = case rule of + Rule {} -> rule { ru_fn = nm } + BuiltinRule {} -> rule { ru_key = nameUnique nm } {- ************************************************************************ ===================================== compiler/GHC/Core/DataCon.hs ===================================== @@ -1810,7 +1810,7 @@ dataConCannotMatch :: [Type] -> DataCon -> Bool dataConCannotMatch tys con -- See (U6) in Note [Implementing unsafeCoerce] -- in base:Unsafe.Coerce - | dataConName con == unsafeReflDataConName + | con `hasKnownKey` unsafeReflDataConKey = False | null inst_theta = False -- Common | all isTyVarTy tys = False -- Also common ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -37,7 +37,7 @@ import GHC.Types.Literal import GHC.Types.Literal.Floating import GHC.Types.Name.Occurrence ( occNameFS ) import GHC.Types.Tickish -import GHC.Types.Name ( Name, nameOccName ) +import GHC.Types.Name ( Name, KnownKeyNameKey, nameUnique, nameOccName ) import GHC.Types.Basic import GHC.Core @@ -870,7 +870,10 @@ primOpRules nm = \case -- useful shorthands mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule -mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules) +mkPrimOpRule nm arity rules + = Just $ mkBasicRule (occNameFS (nameOccName nm)) + (nameUnique nm) + arity (msum rules) mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool) -> [RuleM CoreExpr] -> Maybe CoreRule @@ -1679,13 +1682,13 @@ but that is only a historical accident. ************************************************************************ -} -mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule +mkBasicRule :: RuleName -> KnownKeyNameKey -> Int -> RuleM CoreExpr -> CoreRule -- Gives the Rule the same name as the primop itself -mkBasicRule op_name n_args rm - = BuiltinRule { ru_name = occNameFS (nameOccName op_name), - ru_fn = op_name, - ru_nargs = n_args, - ru_try = runRuleM rm } +mkBasicRule rule_nm op_key n_args rm + = BuiltinRule { ru_name = rule_nm + , ru_key = op_key + , ru_nargs = n_args + , ru_try = runRuleM rm } newtype RuleM r = RuleM { runRuleM :: RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe r } @@ -2060,6 +2063,30 @@ dataToTagRule = a `mplus` b return $ wrapFloats floats (mkIntVal platform (toInteger (dataConTagZ dc))) +{- ********************************************************************* +* * + div and mod +* * +********************************************************************* -} + +divIntRule :: RuleM CoreExpr +divIntRule = msum [ nonZeroLit 1 >> binaryLit (intOp2 div) + , leftZero + , do { [arg, Lit (LitNumber LitNumInt d)] <- getArgs + ; Just n <- return $ exactLog2 d + ; platform <- getPlatform + ; return $ Var (primOpId IntSraOp) + `App` arg `App` mkIntVal platform n } ] + +modIntRule :: RuleM CoreExpr +modIntRule = msum [ nonZeroLit 1 >> binaryLit (intOp2 mod) + , leftZero + , do { [arg, Lit (LitNumber LitNumInt d)] <- getArgs + ; Just _ <- return $ exactLog2 d + ; platform <- getPlatform + ; return $ Var (primOpId IntAndOp) + `App` arg `App` mkIntVal platform (d-1) } ] + {- ********************************************************************* * * unsafeEqualityProof @@ -2132,55 +2159,47 @@ is fine. builtinRules :: [CoreRule] -- Rules for non-primops that can't be expressed using a RULE pragma builtinRules - = [BuiltinRule { ru_name = fsLit "CStringFoldrLit", - ru_fn = unpackCStringFoldrName, - ru_nargs = 4, ru_try = match_cstring_foldr_lit_C }, - BuiltinRule { ru_name = fsLit "CStringFoldrLitUtf8", - ru_fn = unpackCStringFoldrUtf8Name, - ru_nargs = 4, ru_try = match_cstring_foldr_lit_utf8 }, - BuiltinRule { ru_name = fsLit "CStringAppendLit", - ru_fn = unpackCStringAppendName, - ru_nargs = 2, ru_try = match_cstring_append_lit_C }, - BuiltinRule { ru_name = fsLit "CStringAppendLitUtf8", - ru_fn = unpackCStringAppendUtf8Name, - ru_nargs = 2, ru_try = match_cstring_append_lit_utf8 }, - BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName, - ru_nargs = 2, ru_try = match_eq_string }, - BuiltinRule { ru_name = fsLit "CStringLength", ru_fn = cstringLengthName, - ru_nargs = 1, ru_try = match_cstring_length }, - BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName, - ru_nargs = 2, ru_try = \_ _ _ -> match_inline }, - - mkBasicRule unsafeEqualityProofName 3 unsafeEqualityProofRule, - - mkBasicRule divIntName 2 $ msum - [ nonZeroLit 1 >> binaryLit (intOp2 div) - , leftZero - , do - [arg, Lit (LitNumber LitNumInt d)] <- getArgs - Just n <- return $ exactLog2 d - platform <- getPlatform - return $ Var (primOpId IntSraOp) `App` arg `App` mkIntVal platform n - ], - - mkBasicRule modIntName 2 $ msum - [ nonZeroLit 1 >> binaryLit (intOp2 mod) - , leftZero - , do - [arg, Lit (LitNumber LitNumInt d)] <- getArgs - Just _ <- return $ exactLog2 d - platform <- getPlatform - return $ Var (primOpId IntAndOp) - `App` arg `App` mkIntVal platform (d - 1) - ] - ] + = [ BuiltinRule { ru_name = fsLit "CStringFoldrLit" + , ru_key = unpackCStringFoldrIdKey + , ru_nargs = 4, ru_try = match_cstring_foldr_lit_C } + , BuiltinRule { ru_name = fsLit "CStringFoldrLitUtf8" + , ru_key = unpackCStringFoldrUtf8IdKey + ,ru_nargs = 4, ru_try = match_cstring_foldr_lit_utf8 } + , BuiltinRule { ru_name = fsLit "CStringAppendLit" + , ru_key = unpackCStringAppendIdKey + , ru_nargs = 2, ru_try = match_cstring_append_lit_C } + , BuiltinRule { ru_name = fsLit "CStringAppendLitUtf8" + , ru_key = unpackCStringAppendUtf8IdKey + , ru_nargs = 2, ru_try = match_cstring_append_lit_utf8 } + , BuiltinRule { ru_name = fsLit "CStringLength" + , ru_key = cstringLengthIdKey + , ru_nargs = 1, ru_try = match_cstring_length } + + , BuiltinRule { ru_name = fsLit "EqString" + , ru_key = eqStringIdKey + , ru_nargs = 2, ru_try = match_eq_string } + + , BuiltinRule { ru_name = fsLit "Inline" + , ru_key = inlineIdKey + , ru_nargs = 2, ru_try = \_ _ _ -> match_inline } + + , BuiltinRule { ru_name = fsLit "unsafeEqualityProof" + , ru_key = unsafeEqualityProofIdKey + , ru_nargs = 3, ru_try = runRuleM unsafeEqualityProofRule } + + , BuiltinRule { ru_name = fsLit "divInt#" + , ru_key = divIntIdKey + , ru_nargs = 2, ru_try = runRuleM divIntRule } + , BuiltinRule { ru_name = fsLit "modInt#" + , ru_key = modIntIdKey + , ru_nargs = 2, ru_try = runRuleM modIntRule } + ] ++ builtinBignumRules {-# NOINLINE builtinRules #-} --- there is no benefit to inlining these yet, despite this, GHC produces +-- There is no benefit to inlining these yet, despite this, GHC produces -- unfoldings for this regardless since the floated list entries look small. - {- Note [Built-in bignum rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We have some built-in rules for operations on bignum types (Integer, Natural, @@ -2219,54 +2238,54 @@ RuleOpts. builtinBignumRules :: [CoreRule] builtinBignumRules = [ -- conversions - lit_to_integer "Word# -> Integer" integerFromWordName - , lit_to_integer "Int64# -> Integer" integerFromInt64Name - , lit_to_integer "Word64# -> Integer" integerFromWord64Name - , lit_to_integer "Natural -> Integer" integerFromNaturalName + lit_to_integer "Word# -> Integer" integerFromWordIdKey + , lit_to_integer "Int64# -> Integer" integerFromInt64IdKey + , lit_to_integer "Word64# -> Integer" integerFromWord64IdKey + , lit_to_integer "Natural -> Integer" integerFromNaturalIdKey - , integer_to_lit "Integer -> Word# (wrap)" integerToWordName mkWordLitWrap - , integer_to_lit "Integer -> Int# (wrap)" integerToIntName mkIntLitWrap - , integer_to_lit "Integer -> Word64# (wrap)" integerToWord64Name (\_ -> mkWord64LitWord64 . fromInteger) - , integer_to_lit "Integer -> Int64# (wrap)" integerToInt64Name (\_ -> mkInt64LitInt64 . fromInteger) - , integer_to_lit "Integer -> Float#" integerToFloatName (\_ -> mkFloatLit . fromInteger) - , integer_to_lit "Integer -> Double#" integerToDoubleName (\_ -> mkDoubleLit . fromInteger) + , integer_to_lit "Integer -> Word# (wrap)" integerToWordIdKey mkWordLitWrap + , integer_to_lit "Integer -> Int# (wrap)" integerToIntIdKey mkIntLitWrap + , integer_to_lit "Integer -> Word64# (wrap)" integerToWord64IdKey (\_ -> mkWord64LitWord64 . fromInteger) + , integer_to_lit "Integer -> Int64# (wrap)" integerToInt64IdKey (\_ -> mkInt64LitInt64 . fromInteger) + , integer_to_lit "Integer -> Float#" integerToFloatIdKey (\_ -> mkFloatLit . fromInteger) + , integer_to_lit "Integer -> Double#" integerToDoubleIdKey (\_ -> mkDoubleLit . fromInteger) - , integer_to_natural "Integer -> Natural (clamp)" integerToNaturalClampName False True - , integer_to_natural "Integer -> Natural (wrap)" integerToNaturalName False False - , integer_to_natural "Integer -> Natural (throw)" integerToNaturalThrowName True False + , integer_to_natural "Integer -> Natural (clamp)" integerToNaturalClampIdKey False True + , integer_to_natural "Integer -> Natural (wrap)" integerToNaturalIdKey False False + , integer_to_natural "Integer -> Natural (throw)" integerToNaturalThrowIdKey True False - , natural_to_word "Natural -> Word# (wrap)" naturalToWordName + , natural_to_word "Natural -> Word# (wrap)" naturalToWordIdKey -- comparisons (return an unlifted Int#) - , bignum_bin_pred "bigNatEq#" bignatEqName (==) + , bignum_bin_pred "bigNatEq#" bignatEqIdKey (==) -- comparisons (return an Ordering) - , bignum_compare "bignatCompare" bignatCompareName - , bignum_compare "bignatCompareWord#" bignatCompareWordName + , bignum_compare "bignatCompare" bignatCompareIdKey + , bignum_compare "bignatCompareWord#" bignatCompareWordIdKey -- binary operations - , integer_binop "integerAdd" integerAddName (+) - , integer_binop "integerSub" integerSubName (-) - , integer_binop "integerMul" integerMulName (*) - , integer_binop "integerGcd" integerGcdName gcd - , integer_binop "integerLcm" integerLcmName lcm - , integer_binop "integerAnd" integerAndName (.&.) - , integer_binop "integerOr" integerOrName (.|.) - , integer_binop "integerXor" integerXorName xor - - , natural_binop "naturalAdd" naturalAddName (+) - , natural_binop "naturalMul" naturalMulName (*) - , natural_binop "naturalGcd" naturalGcdName gcd - , natural_binop "naturalLcm" naturalLcmName lcm - , natural_binop "naturalAnd" naturalAndName (.&.) - , natural_binop "naturalOr" naturalOrName (.|.) - , natural_binop "naturalXor" naturalXorName xor + , integer_binop "integerAdd" integerAddIdKey (+) + , integer_binop "integerSub" integerSubIdKey (-) + , integer_binop "integerMul" integerMulIdKey (*) + , integer_binop "integerGcd" integerGcdIdKey gcd + , integer_binop "integerLcm" integerLcmIdKey lcm + , integer_binop "integerAnd" integerAndIdKey (.&.) + , integer_binop "integerOr" integerOrIdKey (.|.) + , integer_binop "integerXor" integerXorIdKey xor + + , natural_binop "naturalAdd" naturalAddIdKey (+) + , natural_binop "naturalMul" naturalMulIdKey (*) + , natural_binop "naturalGcd" naturalGcdIdKey gcd + , natural_binop "naturalLcm" naturalLcmIdKey lcm + , natural_binop "naturalAnd" naturalAndIdKey (.&.) + , natural_binop "naturalOr" naturalOrIdKey (.|.) + , natural_binop "naturalXor" naturalXorIdKey xor -- Natural subtraction: it's a binop but it can fail because of underflow so -- we have several primitives to handle here. - , natural_sub "naturalSubUnsafe" naturalSubUnsafeName - , natural_sub "naturalSubThrow" naturalSubThrowName - , mkRule "naturalSub" naturalSubName 2 $ do + , natural_sub "naturalSubUnsafe" naturalSubUnsafeIdKey + , natural_sub "naturalSubThrow" naturalSubThrowIdKey + , mkRule "naturalSub" naturalSubIdKey 2 $ do [a0,a1] <- getArgs x <- isNaturalLiteral a0 y <- isNaturalLiteral a1 @@ -2278,53 +2297,53 @@ builtinBignumRules = else ret 2 $ mkNaturalExpr platform (x - y) -- unary operations - , bignum_unop "integerNegate" integerNegateName mkIntegerExpr negate - , bignum_unop "integerAbs" integerAbsName mkIntegerExpr abs - , bignum_unop "integerComplement" integerComplementName mkIntegerExpr complement + , bignum_unop "integerNegate" integerNegateIdKey mkIntegerExpr negate + , bignum_unop "integerAbs" integerAbsIdKey mkIntegerExpr abs + , bignum_unop "integerComplement" integerComplementIdKey mkIntegerExpr complement - , bignum_popcount "integerPopCount" integerPopCountName mkLitIntWrap - , bignum_popcount "naturalPopCount" naturalPopCountName mkLitWordWrap + , bignum_popcount "integerPopCount" integerPopCountIdKey mkLitIntWrap + , bignum_popcount "naturalPopCount" naturalPopCountIdKey mkLitWordWrap -- Bits.bit - , bignum_bit "integerBit" integerBitName mkIntegerExpr - , bignum_bit "naturalBit" naturalBitName mkNaturalExpr + , bignum_bit "integerBit" integerBitIdKey mkIntegerExpr + , bignum_bit "naturalBit" naturalBitIdKey mkNaturalExpr -- Bits.testBit - , bignum_testbit "integerTestBit" integerTestBitName - , bignum_testbit "naturalTestBit" naturalTestBitName + , bignum_testbit "integerTestBit" integerTestBitIdKey + , bignum_testbit "naturalTestBit" naturalTestBitIdKey -- Bits.shift - , bignum_shift "integerShiftL" integerShiftLName shiftL mkIntegerExpr - , bignum_shift "integerShiftR" integerShiftRName shiftR mkIntegerExpr - , bignum_shift "naturalShiftL" naturalShiftLName shiftL mkNaturalExpr - , bignum_shift "naturalShiftR" naturalShiftRName shiftR mkNaturalExpr + , bignum_shift "integerShiftL" integerShiftLIdKey shiftL mkIntegerExpr + , bignum_shift "integerShiftR" integerShiftRIdKey shiftR mkIntegerExpr + , bignum_shift "naturalShiftL" naturalShiftLIdKey shiftL mkNaturalExpr + , bignum_shift "naturalShiftR" naturalShiftRIdKey shiftR mkNaturalExpr -- division - , divop_one "integerQuot" integerQuotName quot mkIntegerExpr - , divop_one "integerRem" integerRemName rem mkIntegerExpr - , divop_one "integerDiv" integerDivName div mkIntegerExpr - , divop_one "integerMod" integerModName mod mkIntegerExpr - , divop_both "integerDivMod" integerDivModName divMod mkIntegerExpr - , divop_both "integerQuotRem" integerQuotRemName quotRem mkIntegerExpr + , divop_one "integerQuot" integerQuotIdKey quot mkIntegerExpr + , divop_one "integerRem" integerRemIdKey rem mkIntegerExpr + , divop_one "integerDiv" integerDivIdKey div mkIntegerExpr + , divop_one "integerMod" integerModIdKey mod mkIntegerExpr + , divop_both "integerDivMod" integerDivModIdKey divMod mkIntegerExpr + , divop_both "integerQuotRem" integerQuotRemIdKey quotRem mkIntegerExpr - , divop_one "naturalQuot" naturalQuotName quot mkNaturalExpr - , divop_one "naturalRem" naturalRemName rem mkNaturalExpr - , divop_both "naturalQuotRem" naturalQuotRemName quotRem mkNaturalExpr + , divop_one "naturalQuot" naturalQuotIdKey quot mkNaturalExpr + , divop_one "naturalRem" naturalRemIdKey rem mkNaturalExpr + , divop_both "naturalQuotRem" naturalQuotRemIdKey quotRem mkNaturalExpr -- conversions from Rational for Float/Double literals - , rational_to "rationalToFloat#" rationalToFloatName LitFloat - , rational_to "rationalToDouble#" rationalToDoubleName LitDouble + , rational_to "rationalToFloat#" rationalToFloatIdKey LitFloat + , rational_to "rationalToDouble#" rationalToDoubleIdKey LitDouble -- conversions from Integer for Float/Double literals - , integer_encode_float "integerEncodeFloat" integerEncodeFloatName + , integer_encode_float "integerEncodeFloat" integerEncodeFloatIdKey encodeLitFloat LitFloat - , integer_encode_float "integerEncodeDouble" integerEncodeDoubleName + , integer_encode_float "integerEncodeDouble" integerEncodeDoubleIdKey encodeLitDouble LitDouble ] where - mkRule str name nargs f = BuiltinRule + mkRule str key nargs f = BuiltinRule { ru_name = fsLit str - , ru_fn = name + , ru_key = key , ru_nargs = nargs , ru_try = runRuleM $ do env <- getRuleOpts @@ -2470,7 +2489,8 @@ builtinBignumRules = platform <- getPlatform pure $ mkCoreUnboxedTuple [mk_lit platform r, mk_lit platform s] - integer_encode_float :: String -> Name -> (Integer -> Int -> LitFloating) -> LitFloatingType -> CoreRule + integer_encode_float :: String -> KnownKeyNameKey + -> (Integer -> Int -> LitFloating) -> LitFloatingType -> CoreRule integer_encode_float str name encode_fun destType = mkRule str name 2 $ do [a0,a1] <- getArgs x <- isIntegerLiteral a0 @@ -2479,7 +2499,7 @@ builtinBignumRules = yInt <- liftMaybe (toIntegralSized y :: Maybe Int) pure $ Lit $ LitFloating destType $ encode_fun x yInt - rational_to :: String -> Name -> LitFloatingType -> CoreRule + rational_to :: String -> KnownKeyNameKey -> LitFloatingType -> CoreRule rational_to str name destType = mkRule str name 2 $ do -- This turns `rationalToFloat# n d` where `n` and `d` are literals into -- a literal Float# (and similarly for Double#). ===================================== compiler/GHC/Core/Ppr.hs ===================================== @@ -27,25 +27,27 @@ module GHC.Core.Ppr ( import GHC.Prelude import GHC.Core +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.TyCo.Ppr +import GHC.Core.Coercion import GHC.Core.Stats (exprStats) + import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Types.Literal( pprLiteral ) -import GHC.Types.Name( pprInfixName, pprPrefixName ) +import GHC.Types.Name( pprInfixName, pprPrefixName, pprKnownKey ) import GHC.Types.Var import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.InlinePragma import GHC.Types.Demand import GHC.Types.Cpr -import GHC.Core.DataCon -import GHC.Core.TyCon -import GHC.Core.TyCo.Ppr -import GHC.Core.Coercion +import GHC.Types.SrcLoc ( pprUserRealSpan ) +import GHC.Types.Tickish import GHC.Types.Basic + import GHC.Utils.Misc import GHC.Utils.Outputable -import GHC.Types.SrcLoc ( pprUserRealSpan ) -import GHC.Types.Tickish {- ************************************************************************ @@ -668,8 +670,8 @@ pprRules :: [CoreRule] -> SDoc pprRules rules = vcat (map pprRule rules) pprRule :: CoreRule -> SDoc -pprRule (BuiltinRule { ru_fn = fn, ru_name = name}) - = text "Built in rule for" <+> ppr fn <> colon <+> doubleQuotes (ftext name) +pprRule (BuiltinRule { ru_key = key, ru_name = name}) + = text "Built in rule for" <+> pprKnownKey key <> colon <+> doubleQuotes (ftext name) pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn, ru_bndrs = tpl_vars, ru_args = tpl_args, ===================================== compiler/GHC/Core/Rules.hs ===================================== @@ -79,8 +79,8 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Name ( Name, NamedThing(..), nameIsLocalOrFrom ) import GHC.Types.Name.Set -import GHC.Types.Name.Env import GHC.Types.Name.Occurrence( occNameFS ) +import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Tickish import GHC.Types.Basic @@ -357,7 +357,7 @@ addIdSpecialisations id rules addRulesToId :: RuleBase -> Id -> Id -- Add rules in the RuleBase to the rules in the Id addRulesToId rule_base bndr - | Just rules <- lookupNameEnv rule_base (idName bndr) + | Just rules <- lookupRuleBase rule_base (idUnique bndr) = bndr `addIdSpecialisations` rules | otherwise = bndr @@ -376,12 +376,12 @@ rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds -} -- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules -type RuleBase = NameEnv [CoreRule] +type RuleBase = UniqFM Unique [CoreRule] -- The rules are unordered; -- we sort out any overlaps on lookup emptyRuleBase :: RuleBase -emptyRuleBase = emptyNameEnv +emptyRuleBase = emptyUFM mkRuleBase :: [CoreRule] -> RuleBase mkRuleBase rules = extendRuleBaseList emptyRuleBase rules @@ -392,7 +392,10 @@ extendRuleBaseList rule_base new_guys extendRuleBase :: RuleBase -> CoreRule -> RuleBase extendRuleBase rule_base rule - = extendNameEnv_Acc (:) Utils.singleton rule_base (ruleIdName rule) rule + = addToUFM_Acc (:) Utils.singleton rule_base (ruleKey rule) rule + +lookupRuleBase :: RuleBase -> Unique -> Maybe [CoreRule] +lookupRuleBase = lookupUFM pprRuleBase :: RuleBase -> SDoc pprRuleBase rules = pprUFM rules $ \rss -> @@ -440,9 +443,9 @@ addLocalRules rule_env rules = rule_env { re_local_rules = extendRuleBaseList (re_local_rules rule_env) rules } emptyRuleEnv :: RuleEnv -emptyRuleEnv = RuleEnv { re_local_rules = emptyNameEnv - , re_home_rules = emptyNameEnv - , re_eps_rules = emptyNameEnv +emptyRuleEnv = RuleEnv { re_local_rules = emptyRuleBase + , re_home_rules = emptyRuleBase + , re_eps_rules = emptyRuleBase , re_visible_orphs = emptyModuleSet } getRules :: RuleEnv -> Id -> [CoreRule] @@ -478,10 +481,10 @@ getRules (RuleEnv { re_local_rules = local_rule_base drop_orphs eps_rules ++ idCoreRules fn where - fn_name = idName fn + fn_key = idUnique fn drop_orphs [] = [] -- Fast path; avoid invoking recursive filter drop_orphs xs = filter (ruleIsVisible orphs) xs - get rb = lookupNameEnv rb fn_name `orElse` [] + get rb = lookupRuleBase rb fn_key `orElse` [] ruleIsVisible :: ModuleSet -> CoreRule -> Bool ruleIsVisible _ BuiltinRule{} = True ===================================== compiler/GHC/HsToCore.hs ===================================== @@ -715,8 +715,8 @@ magicDefnModules = mkModuleSet $ map (nameModule . getName . fst) magicDefns mkUnsafeCoercePrimPair :: Id -> CoreExpr -> DsM (Id, CoreExpr) -- See Note [Wiring in unsafeCoerce#] for the defn we are creating here mkUnsafeCoercePrimPair _old_id old_expr - = do { unsafe_equality_proof_id <- dsLookupGlobalId unsafeEqualityProofName - ; unsafe_equality_tc <- dsLookupTyCon unsafeEqualityTyConName + = do { unsafe_equality_proof_id <- dsLookupKnownKeyId unsafeEqualityProofIdKey + ; unsafe_equality_tc <- dsLookupKnownKeyTyCon unsafeEqualityTyConKey ; let [unsafe_refl_data_con] = tyConDataCons unsafe_equality_tc ===================================== compiler/GHC/HsToCore/Match/Literal.hs ===================================== @@ -609,7 +609,7 @@ matchLiterals (var :| vars) ty sub_groups -- we can use a case expression; for String we need -- a chain of if-then-else ; if isStringTy (idType var) then - do { eq_str <- dsLookupGlobalId eqStringName + do { eq_str <- dsLookupKnownKeyId eqStringIdKey ; mrs <- mapM (wrap_str_guard eq_str) alts ; return (foldr1 combineMatchResults mrs) } else ===================================== compiler/GHC/Tc/Deriv/Generate.hs ===================================== @@ -213,13 +213,29 @@ produced don't get through the typechecker. gen_Eq_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec) gen_Eq_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon , dit_rep_tc_args = tycon_args }) = do - do { eq_RDR <- rnLookupKnownKeyRdr eqClassOpKey - ; return ([mk_eq_bind eq_RDR], emptyBag) } + do { eq_RDR <- tcLookupKnownKey_RDR eqClassOpKey + ; ([mk_eq_bind eq_RDR], emptyBag) } where all_cons = getPossibleDataCons tycon tycon_args non_nullary_cons = filter (not . isNullarySrcDataCon) all_cons - ------------------------------------------------------------------ + -- Generate tag check. See #17240 + eq_expr_with_tag_check = nlHsCase + (nlHsPar (untag_Expr [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] + (nlHsOpApp (nlHsVar ah_RDR) neInt_RDR (nlHsVar bh_RDR)))) + [ mkHsCaseAlt (nlLitPat (HsIntPrim NoSourceText 1)) false_Expr + , mkHsCaseAlt nlWildPat ( + nlHsCase + (nlHsVar a_RDR) + -- Only one branch to match all nullary constructors + -- as we already know the tags match but do not emit + -- the branch if there are no nullary constructors + (let non_nullary_pats = map pats_etc non_nullary_cons + in if null non_nullary_cons + then non_nullary_pats + else non_nullary_pats ++ [mkHsCaseAlt nlWildPat true_Expr])) + ] + mk_eq_bind eq_RDR = mkFunBindEC 2 loc eq_RDR (const true_Expr) binds where binds @@ -239,45 +255,29 @@ gen_Eq_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon | otherwise = [([a_Pat, b_Pat], eq_expr_with_tag_check)] - -- Generate tag check. See #17240 - eq_expr_with_tag_check = nlHsCase - (nlHsPar (untag_Expr [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] - (nlHsOpApp (nlHsVar ah_RDR) neInt_RDR (nlHsVar bh_RDR)))) - [ mkHsCaseAlt (nlLitPat (HsIntPrim NoSourceText 1)) false_Expr - , mkHsCaseAlt nlWildPat ( - nlHsCase - (nlHsVar a_RDR) - -- Only one branch to match all nullary constructors - -- as we already know the tags match but do not emit - -- the branch if there are no nullary constructors - (let non_nullary_pats = map pats_etc non_nullary_cons - in if null non_nullary_cons - then non_nullary_pats - else non_nullary_pats ++ [mkHsCaseAlt nlWildPat true_Expr])) - ] - - nested_eq_expr [] [] [] = true_Expr - nested_eq_expr tys as bs - = foldr1 and_Expr $ expectNonEmpty $ zipWith3Equal nested_eq tys as bs - -- Using 'foldr1' here ensures that the derived code is correctly - -- associated. See #10859. - where - nested_eq ty a b = nlHsPar (eq_Expr eq_RDR ty (nlHsVar a) (nlHsVar b)) + ------------------------------------------------------------------ + nested_eq_expr [] [] [] = true_Expr + nested_eq_expr tys as bs + = foldr1 and_Expr $ expectNonEmpty $ zipWith3Equal nested_eq tys as bs + -- Using 'foldr1' here ensures that the derived code is correctly + -- associated. See #10859. + where + nested_eq ty a b = nlHsPar (eq_Expr ty (nlHsVar a) (nlHsVar b)) - gen_con_fields_and_tys data_con - | tys_needed <- derivDataConInstArgTys data_con dit - , con_arity <- length tys_needed - , as_needed <- take con_arity as_RDRs - , bs_needed <- take con_arity bs_RDRs - = (as_needed, bs_needed, tys_needed) + gen_con_fields_and_tys data_con + | tys_needed <- derivDataConInstArgTys data_con dit + , con_arity <- length tys_needed + , as_needed <- take con_arity as_RDRs + , bs_needed <- take con_arity bs_RDRs + = (as_needed, bs_needed, tys_needed) - pats_etc data_con - | (as_needed, bs_needed, tys_needed) <- gen_con_fields_and_tys data_con - , data_con_RDR <- getRdrName data_con - , con1_pat <- nlParPat $ nlConVarPat data_con_RDR as_needed - , con2_pat <- nlParPat $ nlConVarPat data_con_RDR bs_needed - , fields_eq_expr <- nested_eq_expr tys_needed as_needed bs_needed - = mkHsCaseAlt con1_pat (nlHsCase (nlHsVar b_RDR) [mkHsCaseAlt con2_pat fields_eq_expr]) + pats_etc data_con + | (as_needed, bs_needed, tys_needed) <- gen_con_fields_and_tys data_con + , data_con_RDR <- getRdrName data_con + , con1_pat <- nlParPat $ nlConVarPat data_con_RDR as_needed + , con2_pat <- nlParPat $ nlConVarPat data_con_RDR bs_needed + , fields_eq_expr <- nested_eq_expr tys_needed as_needed bs_needed + = mkHsCaseAlt con1_pat (nlHsCase (nlHsVar b_RDR) [mkHsCaseAlt con2_pat fields_eq_expr]) {- ************************************************************************ @@ -650,17 +650,16 @@ gen_Enum_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do -- See Note [Auxiliary binders] tag2con_RDR <- new_tag2con_rdr_name loc tycon maxtag_RDR <- new_maxtag_rdr_name loc tycon - eq_RDR <- rnLookupKnownKeyRdr eqClassOpKey - return ( method_binds eq_RDR tag2con_RDR maxtag_RDR + return ( method_binds tag2con_RDR maxtag_RDR , aux_binds tag2con_RDR maxtag_RDR ) where - method_binds eq_RDR tag2con_RDR maxtag_RDR = - [ succ_enum eq_RDR tag2con_RDR maxtag_RDR - , pred_enum eq_RDR tag2con_RDR - , to_enum tag2con_RDR maxtag_RDR - , enum_from tag2con_RDR maxtag_RDR -- [0 ..] - , enum_from_then tag2con_RDR maxtag_RDR -- [0, 1 ..] + method_binds tag2con_RDR maxtag_RDR = + [ succ_enum tag2con_RDR maxtag_RDR + , pred_enum tag2con_RDR + , to_enum tag2con_RDR maxtag_RDR + , enum_from tag2con_RDR maxtag_RDR -- [0 ..] + , enum_from_then tag2con_RDR maxtag_RDR -- [0, 1 ..] , from_enum ] aux_binds tag2con_RDR maxtag_RDR = listToBag @@ -670,7 +669,7 @@ gen_Enum_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do occ_nm = getOccString tycon - succ_enum eq_RDR tag2con_RDR maxtag_RDR + succ_enum tag2con_RDR maxtag_RDR = mkSimpleGeneratedFunBind loc succ_RDR (noLocA [a_Pat]) $ untag_Expr [(a_RDR, ah_RDR)] $ nlHsIf (nlHsApps eq_RDR [nlHsVar maxtag_RDR, @@ -680,7 +679,7 @@ gen_Enum_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], nlHsIntLit 1])) - pred_enum eq_RDR tag2con_RDR + pred_enum tag2con_RDR = mkSimpleGeneratedFunBind loc pred_RDR (noLocA [a_Pat]) $ untag_Expr [(a_RDR, ah_RDR)] $ nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0, @@ -2487,8 +2486,8 @@ and_Expr a b = genOpApp a and_RDR b ----------------------------------------------------------------------- -eq_Expr :: RdrName -> Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -eq_Expr eq_RDR ty a b +eq_Expr :: Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs +eq_Expr ty a b | not (isUnliftedType ty) = genOpApp a eq_RDR b | otherwise = genPrimOpApp a prim_eq b where ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -515,7 +515,7 @@ mkDictSelId name clas -- op (dfT d1 d2) ---> opT d1 d2 rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS` occNameFS (getOccName name) - , ru_fn = name + , ru_key = nameUnique name , ru_nargs = n_ty_args + 1 , ru_try = dictSelRule val_index n_ty_args } ===================================== compiler/GHC/Types/Name.hs ===================================== @@ -127,6 +127,9 @@ A "known-key" name is one * but that's all that GHC knows about it In particular, GHC does /not/ know in which module the entity is defined. +See Note [Recipe for adding a known-key name] for +how to add a known-key name to GHC. + Example: the `Eq` class has OccName "Eq" and unique `eqClassKey`. It happens to be defined in ghc-internal:GHC.Internal.Classes, but GHC does not know that. @@ -245,6 +248,32 @@ Wrinkles (KKN1) We need some special treatment of unused-import warnings. See (UI1) in Note [Unused imports] in GHC.Rename.Names +Note [Recipe for adding a known-key name] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To make `wombat` into a known-key name, you must ensure that: + +* The module M that defines `wombat` is compiled with `-fdefines-known-key-names`. + +* If M.hs has an `M.hs-boot` file, it too must be compiled + with `-fdefines-known-key-names`. + +* The module `GHC.KnownKeyNames` must export `wombat`. + +* The big list `GHC.Builtin.Names.knownKeyTable` must contain an + entry for `wombat`. + +* In any module in `base` or `ghc-internal` (which are compiled with + -frebindable-known-key-names), you must ensure that `wombat` is in scope + by saying `import M( wombat )`. + + If you just say `import M` you may get a "unused import" warning; that + warning is suppressed for known-key names if you import `wombat` by name. + + You do not need to import the module in which `wombat` is /defined/, although + you may. It is enough simply to bring `wombat` in scope by importing a + module that re-exports. You can even import `GHC.KnownKeyNames`, if that does + not create a module loop! + Note [About the NameSorts] ~~~~~~~~~~~~~~~~~~~~~~~~~~ 1. Initially: ===================================== compiler/GHC/Types/Name/Reader.hs ===================================== @@ -196,7 +196,7 @@ data RdrName -- we want to say \"Use Prelude.map dammit\". One of these -- can be created with 'mkOrig' - | Exact Name + | Exact ExactSpec -- ^ Exact name -- -- We know exactly the 'Name'. This is used: @@ -209,6 +209,11 @@ data RdrName -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' deriving Data +data ExactSpec + = ExactName Name -- Use this when you know the exact Name + | ExactKey KnownKeyNameKey -- Use this for known-key names + deriving Data + {- ************************************************************************ * * @@ -287,7 +292,7 @@ getRdrName :: NamedThing thing => thing -> RdrName getRdrName name = nameRdrName (getName name) nameRdrName :: Name -> RdrName -nameRdrName name = Exact name +nameRdrName name = Exact (ExactName name) -- Keep the Name even for Internal names, so that the -- unique is still there for debug printing, particularly -- of Types (which are converted to IfaceTypes before printing) ===================================== compiler/GHC/Types/Unique/FM.hs ===================================== @@ -176,6 +176,8 @@ addToUFM_C -> UniqFM key elt -- ^ old -> key -> elt -- ^ new -> UniqFM key elt -- ^ result +{-# SPECIALISE addToUFM_C :: (elt -> elt -> elt) -> UniqFM Unique elt + -> Unique -> elt -> UniqFM Unique elt #-} -- Arguments of combining function of M.insertWith and addToUFM_C are flipped. addToUFM_C f (UFM m) k v = UFM (M.insertWith (flip f) (getKey $ getUnique k) v m) @@ -197,6 +199,8 @@ addToUFM_Acc -> UniqFM key elts -- old -> key -> elt -- new -> UniqFM key elts -- result +{-# SPECIALISE addToUFM_Acc :: (elt -> elts -> elts) -> (elt->elts) -> UniqFM Unique elts + -> Unique -> elt -> UniqFM Unique elts #-} addToUFM_Acc exi new (UFM m) k v = UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m) ===================================== libraries/base/src/Data/Functor/Classes.hs ===================================== @@ -71,6 +71,8 @@ module Data.Functor.Classes ( showsBinary1, ) where +import GHC.KnownKeyNames + import Control.Applicative (Alternative((<|>)), Const(Const)) import GHC.Internal.Data.Functor.Identity (Identity(Identity)) @@ -90,6 +92,7 @@ import GHC.Internal.Text.Read.Lex (Lexeme(..)) import GHC.Internal.Text.Show (showListWith) import Prelude + -- $setup -- >>> import Prelude -- >>> import Data.Complex (Complex (..)) ===================================== libraries/base/src/GHC/KnownKeyNames.hs ===================================== @@ -1,4 +1,4 @@ -{-# LANGUAGE Trustworthy, RankNTypes #-} +{-# LANGUAGE MagicHash, Trustworthy, RankNTypes #-} {-# OPTIONS_GHC -fdefines-known-key-names #-} -- See Note [Known-key names and IsList] @@ -32,6 +32,7 @@ module GHC.KnownKeyNames , Num, Integral, Real , (-), negate, fromInteger, fromRational , mkRationalBase2, mkRationalBase10 + , divInt#, modInt# -- Strings , IsString @@ -47,12 +48,37 @@ module GHC.KnownKeyNames -- IO , thenIO, bindIO, returnIO, print + + -- Names that have BuiltinRules + , CS.unpackFoldrCString#, CS.unpackFoldrCStringUtf8#, CS.unpackAppendCString# + , CS.unpackAppendCStringUtf8#, CS.cstringLength# + , eqString, inline + + , UnsafeEquality( UnsafeRefl ), unsafeEqualityProof + + -- Bignums + , bigNatEq#, bigNatCompare, bigNatCompareWord# + , naturalToWord#, naturalPopCount#, naturalShiftR#, naturalShiftL# + , naturalAdd, naturalSub, naturalSubThrow, naturalSubUnsafe + , naturalMul, naturalQuotRem#, naturalQuot, naturalRem, naturalAnd + , naturalOr, naturalXor, naturalTestBit#, naturalBit#, naturalGcd, naturalLcm + + , integerFromNatural, integerToNaturalClamp, integerToNaturalThrow, integerToNatural + , integerToWord#, integerToInt#, integerToWord64#, integerToInt64#, integerFromWord# + , integerFromWord64#, integerFromInt64#, integerAdd, integerMul, integerSub + , integerNegate, integerAbs, integerPopCount#, integerQuot, integerRem, integerDiv + , integerMod, integerDivMod#, integerQuotRem#, integerEncodeFloat#, integerEncodeDouble# + , integerGcd, integerLcm, integerAnd, integerOr, integerXor + , integerComplement, integerBit#, integerTestBit#, integerShiftL#, integerShiftR# ) where import Prelude import Data.String( IsString ) -import GHC.Internal.Base( Alternative, join, thenIO, bindIO, returnIO ) +import GHC.Internal.Base( Alternative, join, thenIO, bindIO, returnIO + , eqString ) +import GHC.Internal.Classes( divInt#, modInt# ) import GHC.Internal.Ix( Ix ) +import GHC.Internal.Magic( inline ) import GHC.Internal.Data.Data( Data ) import GHC.Internal.Data.String( fromString ) import GHC.Internal.Real( mkRationalBase2, mkRationalBase10 ) @@ -62,12 +88,20 @@ import GHC.Internal.Control.Monad.Zip( mzip ) import GHC.Internal.Control.Arrow( arr, (>>>), first, app, (|||) ) import GHC.Internal.OverloadedLabels( fromLabel ) import GHC.Internal.Records( HasField, getField ) +import GHC.Internal.CString as CS import qualified GHC.Internal.IsList as IL +import GHC.Internal.Unsafe.Coerce( UnsafeEquality(..), unsafeEqualityProof ) + +import GHC.Internal.Bignum.Integer +import GHC.Internal.Bignum.Natural +import GHC.Internal.Bignum.BigNat + {- Note [Known-key names and IsList] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Very annoyingly both the classes Foldable and IsList have a method `toList`. we can't have two known-key names with the same OccName. + -} isList_toList :: IL.IsList l => l -> [IL.Item l] ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/BigNat.hs ===================================== @@ -9,6 +9,10 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE BinaryLiterals #-} + +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines lots of functions that have BuiltinRules + {-# OPTIONS_GHC -Wno-name-shadowing #-} -- | Multi-precision natural ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/BigNat.hs-boot ===================================== @@ -2,6 +2,9 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines lots of functions that have BuiltinRules + module GHC.Internal.Bignum.BigNat where import GHC.Internal.Bignum.WordArray ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs ===================================== @@ -8,6 +8,9 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines lots of functions that have BuiltinRules + -- | -- Module : GHC.Internal.Bignum.Integer -- Copyright : (c) Sylvain Henry 2019, ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs-boot ===================================== @@ -2,6 +2,9 @@ {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE MagicHash #-} +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines lots of functions that have BuiltinRules + module GHC.Internal.Bignum.Integer where import GHC.Internal.Types ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/Natural.hs ===================================== @@ -5,6 +5,9 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BlockArguments #-} +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines lots of functions that have BuiltinRules + #include "MachDeps.h" #include "WordSize.h" ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/Natural.hs-boot ===================================== @@ -1,6 +1,9 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MagicHash #-} +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines lots of functions that have BuiltinRules + module GHC.Internal.Bignum.Natural where import {-# SOURCE #-} GHC.Internal.Bignum.BigNat ===================================== libraries/ghc-internal/src/GHC/Internal/CString.hs ===================================== @@ -1,4 +1,8 @@ {-# LANGUAGE MagicHash, NoImplicitPrelude, BangPatterns, UnliftedFFITypes #-} + +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines unpackFoldrCString# etc + ----------------------------------------------------------------------------- -- | -- Module : GHC.Internal.CString ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Functor/Const.hs ===================================== @@ -25,9 +25,7 @@ import GHC.Internal.Data.Foldable (Foldable(foldMap)) import GHC.Internal.Foreign.Storable (Storable) import GHC.Internal.Ix (Ix) -import GHC.Internal.Base ( - Applicative(..), Functor(..), Monoid(..), Semigroup(..), ($), (.), - ) +import GHC.Internal.Base import GHC.Internal.Classes (Eq(..), Ord(..)) import GHC.Internal.Enum (Bounded, Enum) import GHC.Internal.Float (Floating, RealFloat) @@ -36,6 +34,7 @@ import GHC.Internal.Prim (coerce) import GHC.Internal.Real (Fractional, Integral, Real, RealFrac) import GHC.Internal.Read (Read(readsPrec), readParen, lex) import GHC.Internal.Show (Show(showsPrec), showParen, showString) + import GHC.Internal.Num( fromInteger ) -- For known-key names -- | The 'Const' functor. ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Functor/Identity.hs ===================================== @@ -34,12 +34,11 @@ module GHC.Internal.Data.Functor.Identity ( import GHC.Internal.Data.Bits (Bits, FiniteBits) import GHC.Internal.Data.Coerce -import GHC.Internal.Data.Foldable +import GHC.Internal.Data.Foldable as Foldable import GHC.Internal.Data.Functor.Utils ((#.)) import GHC.Internal.Foreign.Storable (Storable) import GHC.Internal.Ix (Ix) -import GHC.Internal.Base ( Applicative(..), Functor(..), Monad(..) - , Semigroup, Monoid, ($), (.) ) +import GHC.Internal.Base import GHC.Internal.Classes (Eq(..), Ord(..)) import GHC.Internal.Enum (Bounded, Enum) import GHC.Internal.Float (Floating, RealFloat) @@ -117,7 +116,7 @@ instance Foldable Identity where foldl' = coerce foldl1 _ = runIdentity foldr f z (Identity x) = f x z - foldr' = foldr + foldr' = Foldable.foldr -- Not the one from GHC.Internal.Base! foldr1 _ = runIdentity length _ = 1 maximum = runIdentity ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Ord.hs ===================================== @@ -28,10 +28,7 @@ import GHC.Internal.Classes (Eq(..), Ord(..)) import GHC.Internal.Data.Bits (Bits, FiniteBits, complement) import GHC.Internal.Foreign.Storable (Storable) import GHC.Internal.Ix (Ix) -import GHC.Internal.Base ( - Applicative(..), Functor(..), Monad(..), Monoid, Semigroup, otherwise, - ($), (.), - ) +import GHC.Internal.Base import GHC.Internal.Enum (Bounded(..), Enum(..)) import GHC.Internal.Float (Floating, RealFloat) import GHC.Internal.Num ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Typeable/Internal.hs ===================================== @@ -124,6 +124,7 @@ import {-# SOURCE #-} GHC.Internal.Fingerprint -- import {-# SOURCE #-} GHC.Internal.Debug.Trace (trace) import GHC.Internal.Num( fromInteger ) -- For known-key names +import GHC.Internal.Base( eqString ) -- For known-key names #include "MachDeps.h" ===================================== libraries/ghc-internal/src/GHC/Internal/IO/Encoding.hs ===================================== @@ -36,7 +36,7 @@ module GHC.Internal.IO.Encoding ( argvEncoding ) where -import GHC.Internal.Base (String, return, ($)) +import GHC.Internal.Base (String, return, ($), eqString) import GHC.Internal.Classes (Eq(..)) import GHC.Internal.IO.Exception import GHC.Internal.IO.Buffer ===================================== libraries/ghc-internal/src/GHC/Internal/Magic.hs ===================================== @@ -5,6 +5,10 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneKindSignatures #-} + +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines inline etc + {-# OPTIONS_HADDOCK print-explicit-runtime-reps #-} ----------------------------------------------------------------------------- ===================================== libraries/ghc-internal/src/GHC/Internal/Read.hs ===================================== @@ -83,6 +83,7 @@ import GHC.Internal.Tuple (Solo (..)) import GHC.Internal.ByteOrder import GHC.Internal.Control.Monad.Fail( fail ) -- For known-key names +import GHC.Internal.Base( eqString ) -- For known-key names -- | @'readParen' 'True' p@ parses what @p@ parses, but surrounded with -- parentheses. ===================================== libraries/ghc-internal/src/GHC/Internal/Unsafe/Coerce.hs ===================================== @@ -3,6 +3,9 @@ -- Note [Implementing unsafeCoerce] {-# OPTIONS_GHC -fno-strictness #-} +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines unsafeEqualityProof etc + {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MagicHash #-} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/809c39eee41eccd03294fbc3d7bcf24d... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/809c39eee41eccd03294fbc3d7bcf24d... You're receiving this email because of your account on gitlab.haskell.org.