ghc-lib-parser 0.20210901 → 0.20211001
raw patch · 73 files changed
+2244/−885 lines, 73 files
Files
- compiler/GHC/Builtin/Names.hs +9/−7
- compiler/GHC/Builtin/Types/Prim.hs +19/−1
- compiler/GHC/ByteCode/Types.hs +1/−1
- compiler/GHC/Cmm.hs +2/−3
- compiler/GHC/Core/Coercion.hs +1/−1
- compiler/GHC/Core/Lint.hs +8/−4
- compiler/GHC/Core/Make.hs +9/−4
- compiler/GHC/Core/Map/Type.hs +4/−3
- compiler/GHC/Core/Opt/ConstantFold.hs +305/−366
- compiler/GHC/Core/Reduction.hs +1/−1
- compiler/GHC/Core/SimpleOpt.hs +4/−27
- compiler/GHC/Core/TyCo/Rep.hs +71/−9
- compiler/GHC/Core/TyCon/Env.hs +3/−3
- compiler/GHC/Core/Type.hs +49/−19
- compiler/GHC/Core/Unfold.hs +1/−2
- compiler/GHC/Core/Unify.hs +3/−3
- compiler/GHC/Core/Utils.hs +2/−0
- compiler/GHC/Driver/Flags.hs +3/−1
- compiler/GHC/Driver/Hooks.hs +1/−2
- compiler/GHC/Driver/Session.hs +16/−15
- compiler/GHC/Hs/Dump.hs +4/−0
- compiler/GHC/Hs/Expr.hs +40/−19
- compiler/GHC/Hs/Pat.hs +1/−1
- compiler/GHC/Hs/Utils.hs +5/−5
- compiler/GHC/HsToCore/Errors/Ppr.hs +1/−1
- compiler/GHC/HsToCore/Pmc/Solver/Types.hs +34/−13
- compiler/GHC/Iface/Type.hs +45/−34
- compiler/GHC/Parser/Annotation.hs +5/−1
- compiler/GHC/Parser/Errors/Ppr.hs +3/−0
- compiler/GHC/Parser/Errors/Types.hs +2/−0
- compiler/GHC/Parser/PostProcess.hs +28/−18
- compiler/GHC/Platform.hs +6/−0
- compiler/GHC/Platform/Reg.hs +11/−3
- compiler/GHC/Runtime/Heap/Layout.hs +4/−0
- compiler/GHC/Tc/Errors/Ppr.hs +416/−6
- compiler/GHC/Tc/Errors/Types.hs +617/−4
- compiler/GHC/Tc/Types.hs +3/−72
- compiler/GHC/Tc/Types/Origin.hs +1/−3
- compiler/GHC/Tc/Types/Rank.hs +40/−0
- compiler/GHC/Tc/Utils/TcType.hs +12/−22
- compiler/GHC/Tc/Utils/TcType.hs-boot +4/−0
- compiler/GHC/Types/Avail.hs +2/−2
- compiler/GHC/Types/Basic.hs +6/−1
- compiler/GHC/Types/Cpr.hs +23/−14
- compiler/GHC/Types/Demand.hs +1/−1
- compiler/GHC/Types/Error.hs +1/−0
- compiler/GHC/Types/Hint.hs +18/−1
- compiler/GHC/Types/Hint/Ppr.hs +20/−4
- compiler/GHC/Types/IPE.hs +21/−6
- compiler/GHC/Types/Id.hs +3/−4
- compiler/GHC/Types/Id/Info.hs +5/−5
- compiler/GHC/Types/Id/Make.hs +0/−27
- compiler/GHC/Types/Literal.hs +45/−57
- compiler/GHC/Types/Name/Env.hs +13/−3
- compiler/GHC/Types/Name/Occurrence.hs +3/−3
- compiler/GHC/Types/Name/Reader.hs +3/−3
- compiler/GHC/Types/TypeEnv.hs +1/−1
- compiler/GHC/Types/Unique/FM.hs +11/−9
- compiler/GHC/Types/Unique/Map.hs +1/−1
- compiler/GHC/Types/Unique/Supply.hs +1/−1
- compiler/GHC/Types/Var.hs-boot +1/−0
- compiler/GHC/Unit/Home/ModInfo.hs +1/−1
- compiler/GHC/Unit/Module/Deps.hs +180/−3
- compiler/GHC/Unit/Module/ModSummary.hs +7/−5
- compiler/Language/Haskell/Syntax/Expr.hs +1/−16
- ghc-lib-parser.cabal +2/−1
- ghc-lib/stage0/compiler/build/GHC/Parser.hs +42/−31
- ghc-lib/stage0/compiler/build/primop-docs.hs-incl +1/−0
- ghc-lib/stage0/lib/ghcautoconf.h +3/−3
- ghc-lib/stage0/lib/settings +4/−3
- ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs +4/−4
- libraries/ghc-boot/GHC/Unit/Database.hs +25/−0
- libraries/ghci/GHCi/Message.hs +1/−1
compiler/GHC/Builtin/Names.hs view
@@ -559,7 +559,7 @@ tYPEABLE, tYPEABLE_INTERNAL, gENERICS, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP, mONAD_FAIL, aRROW, gHC_DESUGAR, rANDOM, gHC_EXTS,- cONTROL_EXCEPTION_BASE, gHC_TYPELITS, gHC_TYPELITS_INTERNAL,+ cONTROL_EXCEPTION_BASE, gHC_TYPEERROR, gHC_TYPELITS, gHC_TYPELITS_INTERNAL, gHC_TYPENATS, gHC_TYPENATS_INTERNAL, dATA_COERCE, dEBUG_TRACE, uNSAFE_COERCE :: Module @@ -621,6 +621,7 @@ gHC_EXTS = mkBaseModule (fsLit "GHC.Exts") cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base") gHC_GENERICS = mkBaseModule (fsLit "GHC.Generics")+gHC_TYPEERROR = mkBaseModule (fsLit "GHC.TypeError") gHC_TYPELITS = mkBaseModule (fsLit "GHC.TypeLits") gHC_TYPELITS_INTERNAL = mkBaseModule (fsLit "GHC.TypeLits.Internal") gHC_TYPENATS = mkBaseModule (fsLit "GHC.TypeNats")@@ -1455,19 +1456,19 @@ :: Name errorMessageTypeErrorFamName =- tcQual gHC_TYPELITS (fsLit "TypeError") errorMessageTypeErrorFamKey+ tcQual gHC_TYPEERROR (fsLit "TypeError") errorMessageTypeErrorFamKey typeErrorTextDataConName =- dcQual gHC_TYPELITS (fsLit "Text") typeErrorTextDataConKey+ dcQual gHC_TYPEERROR (fsLit "Text") typeErrorTextDataConKey typeErrorAppendDataConName =- dcQual gHC_TYPELITS (fsLit ":<>:") typeErrorAppendDataConKey+ dcQual gHC_TYPEERROR (fsLit ":<>:") typeErrorAppendDataConKey typeErrorVAppendDataConName =- dcQual gHC_TYPELITS (fsLit ":$$:") typeErrorVAppendDataConKey+ dcQual gHC_TYPEERROR (fsLit ":$$:") typeErrorVAppendDataConKey typeErrorShowTypeDataConName =- dcQual gHC_TYPELITS (fsLit "ShowType") typeErrorShowTypeDataConKey+ dcQual gHC_TYPEERROR (fsLit "ShowType") typeErrorShowTypeDataConKey -- Unsafe coercion proofs unsafeEqualityProofName, unsafeEqualityTyConName, unsafeCoercePrimName,@@ -1884,7 +1885,7 @@ typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey, funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey, eqReprPrimTyConKey, eqPhantPrimTyConKey,- compactPrimTyConKey :: Unique+ compactPrimTyConKey, stackSnapshotPrimTyConKey :: Unique statePrimTyConKey = mkPreludeTyConUnique 50 stableNamePrimTyConKey = mkPreludeTyConUnique 51 stableNameTyConKey = mkPreludeTyConUnique 52@@ -1912,6 +1913,7 @@ funPtrTyConKey = mkPreludeTyConUnique 78 tVarPrimTyConKey = mkPreludeTyConUnique 79 compactPrimTyConKey = mkPreludeTyConUnique 80+stackSnapshotPrimTyConKey = mkPreludeTyConUnique 81 eitherTyConKey :: Unique eitherTyConKey = mkPreludeTyConUnique 84
compiler/GHC/Builtin/Types/Prim.hs view
@@ -83,6 +83,7 @@ bcoPrimTyCon, bcoPrimTy, weakPrimTyCon, mkWeakPrimTy, threadIdPrimTyCon, threadIdPrimTy,+ stackSnapshotPrimTyCon, stackSnapshotPrimTy, int8PrimTyCon, int8PrimTy, int8PrimTyConName, word8PrimTyCon, word8PrimTy, word8PrimTyConName,@@ -203,6 +204,7 @@ , word16PrimTyCon , word32PrimTyCon , word64PrimTyCon+ , stackSnapshotPrimTyCon , tYPETyCon , funTyCon@@ -225,7 +227,7 @@ BuiltInSyntax -charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, ioPortPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName :: Name+charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, ioPortPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, stackSnapshotPrimTyConName :: Name charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon int8PrimTyConName = mkPrimTc (fsLit "Int8#") int8PrimTyConKey int8PrimTyCon@@ -261,6 +263,7 @@ stablePtrPrimTyConName = mkPrimTc (fsLit "StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon stableNamePrimTyConName = mkPrimTc (fsLit "StableName#") stableNamePrimTyConKey stableNamePrimTyCon compactPrimTyConName = mkPrimTc (fsLit "Compact#") compactPrimTyConKey compactPrimTyCon+stackSnapshotPrimTyConName = mkPrimTc (fsLit "StackSnapshot#") stackSnapshotPrimTyConKey stackSnapshotPrimTyCon #if MIN_VERSION_ghc_prim(0, 7, 0) bcoPrimTyConName = mkPrimTc (fsLit "BCO") bcoPrimTyConKey bcoPrimTyCon@@ -1161,6 +1164,21 @@ compactPrimTy :: Type compactPrimTy = mkTyConTy compactPrimTyCon++{-+************************************************************************+* *+ The @StackSnapshot#@ type+* *+************************************************************************+-}++stackSnapshotPrimTyCon :: TyCon+stackSnapshotPrimTyCon = pcPrimTyCon0 stackSnapshotPrimTyConName UnliftedRep++stackSnapshotPrimTy :: Type+stackSnapshotPrimTy = mkTyConTy stackSnapshotPrimTyCon+ {- ************************************************************************
compiler/GHC/ByteCode/Types.hs view
@@ -68,7 +68,7 @@ seqCompiledByteCode :: CompiledByteCode -> () seqCompiledByteCode CompiledByteCode{..} = rnf bc_bcos `seq`- rnf (nameEnvElts bc_itbls) `seq`+ seqEltsNameEnv rnf bc_itbls `seq` rnf bc_ffis `seq` rnf bc_strs `seq` rnf (fmap seqModBreaks bc_breaks)
compiler/GHC/Cmm.hs view
@@ -167,12 +167,12 @@ -- place to convey this information from the code generator to -- where we build the static closures in -- GHC.Cmm.Info.Build.doSRTs.- }+ } deriving Eq data ProfilingInfo = NoProfilingInfo | ProfilingInfo ByteString ByteString -- closure_type, closure_desc-+ deriving Eq ----------------------------------------------------------------------------- -- Static Data -----------------------------------------------------------------------------@@ -288,4 +288,3 @@ pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc pprBBlock (BasicBlock ident stmts) = hang (ppr ident <> colon) 4 (vcat (map ppr stmts))-
compiler/GHC/Core/Coercion.hs view
@@ -477,7 +477,7 @@ -> (TCvSubst,Kind) -- Rhs kind of coercion -> [Type] -- Arguments to that function -> ([CoercionN], Coercion)- -- Invariant: co :: subst1(k2) ~ subst2(k2)+ -- Invariant: co :: subst1(k1) ~ subst2(k2) go acc_arg_cos (subst1,k1) co (subst2,k2) (ty:tys) | Just (a, t1) <- splitForAllTyCoVar_maybe k1
compiler/GHC/Core/Lint.hs view
@@ -285,10 +285,11 @@ -> CoreToDo -> CoreProgram -> [CoreRule] -> IO () -- Used by the IO-is CorePrep too endPassIO hsc_env print_unqual pass binds rules- = do { dumpPassResult logger print_unqual mb_flag+ = do { dumpPassResult logger dump_core_sizes print_unqual mb_flag (showSDoc dflags (ppr pass)) (pprPassDetails pass) binds rules ; lintPassResult hsc_env pass binds } where+ dump_core_sizes = not (gopt Opt_SuppressCoreSizes dflags) logger = hsc_logger hsc_env dflags = hsc_dflags hsc_env mb_flag = case coreDumpFlag pass of@@ -297,6 +298,7 @@ _ -> Nothing dumpPassResult :: Logger+ -> Bool -- dump core sizes? -> PrintUnqualified -> Maybe DumpFlag -- Just df => show details in a file whose -- name is specified by df@@ -304,7 +306,7 @@ -> SDoc -- Extra info to appear after header -> CoreProgram -> [CoreRule] -> IO ()-dumpPassResult logger unqual mb_flag hdr extra_info binds rules+dumpPassResult logger dump_core_sizes unqual mb_flag hdr extra_info binds rules = do { forM_ mb_flag $ \flag -> do logDumpFile logger (mkDumpStyle unqual) flag hdr FormatCore dump_doc @@ -320,7 +322,9 @@ dump_doc = vcat [ nest 2 extra_info , size_doc , blankLine- , pprCoreBindingsWithSize binds+ , if dump_core_sizes+ then pprCoreBindingsWithSize binds+ else pprCoreBindings binds , ppUnless (null rules) pp_rules ] pp_rules = vcat [ blankLine , text "------ Local rules for imported ids --------"@@ -3294,7 +3298,7 @@ -- consistency checks: We check this by running the given task twice, -- noting all differences between the results. lintAnnots :: SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts-lintAnnots pname pass guts = do+lintAnnots pname pass guts = {-# SCC "lintAnnots" #-} do -- Run the pass as we normally would dflags <- getDynFlags logger <- getLogger
compiler/GHC/Core/Make.hs view
@@ -304,12 +304,17 @@ mkWordExpr platform w = mkCoreConApps wordDataCon [mkWordLit platform w] -- | Create a 'CoreExpr' which will evaluate to the given @Integer@-mkIntegerExpr :: Integer -> CoreExpr -- Result :: Integer-mkIntegerExpr i = Lit (mkLitInteger i)+mkIntegerExpr :: Platform -> Integer -> CoreExpr -- Result :: Integer+mkIntegerExpr platform i+ | platformInIntRange platform i = mkCoreConApps integerISDataCon [mkIntLit platform i]+ | i < 0 = mkCoreConApps integerINDataCon [Lit (mkLitBigNat (negate i))]+ | otherwise = mkCoreConApps integerIPDataCon [Lit (mkLitBigNat i)] -- | Create a 'CoreExpr' which will evaluate to the given @Natural@-mkNaturalExpr :: Integer -> CoreExpr-mkNaturalExpr i = Lit (mkLitNatural i)+mkNaturalExpr :: Platform -> Integer -> CoreExpr+mkNaturalExpr platform w+ | platformInWordRange platform w = mkCoreConApps naturalNSDataCon [mkWordLit platform w]+ | otherwise = mkCoreConApps naturalNBDataCon [Lit (mkLitBigNat w)] -- | Create a 'CoreExpr' which will evaluate to the given @Float@ mkFloatExpr :: Float -> CoreExpr
compiler/GHC/Core/Map/Type.hs view
@@ -48,13 +48,13 @@ import GHC.Types.Unique.FM import GHC.Utils.Outputable -import GHC.Data.Maybe import GHC.Utils.Panic import qualified Data.Map as Map import qualified Data.IntMap as IntMap import Control.Monad ( (>=>) )+import GHC.Data.Maybe -- NB: Be careful about RULES and type families (#5821). So we should make sure -- to specify @Key TypeMapX@ (and not @DeBruijn Type@, the reduced form)@@ -136,16 +136,17 @@ type TypeMapG = GenMap TypeMapX -- | @TypeMapX a@ is the base map from @DeBruijn Type@ to @a@, but without the--- 'GenMap' optimization.+-- 'GenMap' optimization. See Note [Computing equality on types] in GHC.Core.Type. data TypeMapX a = TM { tm_var :: VarMap a- , tm_app :: TypeMapG (TypeMapG a)+ , tm_app :: TypeMapG (TypeMapG a) -- Note [Equality on AppTys] in GHC.Core.Type , tm_tycon :: DNameEnv a -- only InvisArg arrows here , tm_funty :: TypeMapG (TypeMapG (TypeMapG a)) -- keyed on the argument, result rep, and result -- constraints are never linear-restricted and are always lifted+ -- See also Note [Equality on FunTys] in GHC.Core.TyCo.Rep , tm_forall :: TypeMapG (BndrMap a) -- See Note [Binders] in GHC.Core.Map.Expr , tm_tylit :: TyLitMap a
compiler/GHC/Core/Opt/ConstantFold.hs view
@@ -47,7 +47,7 @@ import GHC.Core import GHC.Core.Make import GHC.Core.SimpleOpt ( exprIsConApp_maybe, exprIsLiteral_maybe )-import GHC.Core.DataCon ( dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId )+import GHC.Core.DataCon ( DataCon,dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId ) import GHC.Core.Utils ( eqExpr, cheapEqExpr, exprIsHNF, exprType , stripTicksTop, stripTicksTopT, mkTicks ) import GHC.Core.Multiplicity@@ -78,7 +78,7 @@ import qualified Data.ByteString as BS import Data.Ratio import Data.Word-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, fromJust) {- Note [Constant folding]@@ -158,11 +158,13 @@ , idempotent , zeroElem , sameArgIdempotentCommut Word8AndOp+ , andFoldingRules word8Ops ] Word8OrOp -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 (.|.)) , idempotent , identity zeroW8 , sameArgIdempotentCommut Word8OrOp+ , orFoldingRules word8Ops ] Word8XorOp -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 xor) , identity zeroW8@@ -229,11 +231,13 @@ , idempotent , zeroElem , sameArgIdempotentCommut Word16AndOp+ , andFoldingRules word16Ops ] Word16OrOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 (.|.)) , idempotent , identity zeroW16 , sameArgIdempotentCommut Word16OrOp+ , orFoldingRules word16Ops ] Word16XorOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 xor) , identity zeroW16@@ -300,11 +304,13 @@ , idempotent , zeroElem , sameArgIdempotentCommut Word32AndOp+ , andFoldingRules word32Ops ] Word32OrOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 (.|.)) , idempotent , identity zeroW32 , sameArgIdempotentCommut Word32OrOp+ , orFoldingRules word32Ops ] Word32XorOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 xor) , identity zeroW32@@ -370,11 +376,13 @@ , idempotent , zeroElem , sameArgIdempotentCommut Word64AndOp+ , andFoldingRules word64Ops ] Word64OrOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (.|.)) , idempotent , identity zeroW64 , sameArgIdempotentCommut Word64OrOp+ , orFoldingRules word64Ops ] Word64XorOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 xor) , identity zeroW64@@ -404,6 +412,39 @@ , identityPlatform onei , mulFoldingRules IntMulOp intOps ]+ IntMul2Op -> mkPrimOpRule nm 2 [ do+ [Lit (LitNumber _ l1), Lit (LitNumber _ l2)] <- getArgs+ platform <- getPlatform+ let r = l1 * l2+ pure $ mkCoreUbxTup [intPrimTy,intPrimTy,intPrimTy]+ [ Lit (if platformInIntRange platform r then zeroi platform else onei platform)+ , mkIntLitWrap platform (r `shiftR` platformWordSizeInBits platform)+ , mkIntLitWrap platform r+ ]++ , zeroElem >>= \z ->+ pure (mkCoreUbxTup [intPrimTy,intPrimTy,intPrimTy]+ [z,z,z])++ -- timesInt2# 1# other+ -- ~~~>+ -- (# 0#, 0# -# (other >># (WORD_SIZE_IN_BITS-1)), other #)+ -- The second element is the sign bit+ -- repeated to fill a word.+ , identityPlatform onei >>= \other -> do+ platform <- getPlatform+ pure $ mkCoreUbxTup [intPrimTy,intPrimTy,intPrimTy]+ [ Lit (zeroi platform)+ , mkCoreApps (Var (mkPrimOpId IntSubOp))+ [ Lit (zeroi platform)+ , mkCoreApps (Var (mkPrimOpId IntSrlOp))+ [ other+ , mkIntLit platform (fromIntegral (platformWordSizeInBits platform - 1))+ ]+ ]+ , other+ ]+ ] IntQuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot) , leftZero , rightIdentityPlatform onei@@ -416,11 +457,13 @@ , idempotent , zeroElem , sameArgIdempotentCommut IntAndOp+ , andFoldingRules intOps ] IntOrOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (.|.)) , idempotent , identityPlatform zeroi , sameArgIdempotentCommut IntOrOp+ , orFoldingRules intOps ] IntXorOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 xor) , identityPlatform zeroi@@ -465,11 +508,13 @@ , idempotent , zeroElem , sameArgIdempotentCommut WordAndOp+ , andFoldingRules wordOps ] WordOrOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.)) , idempotent , identityPlatform zerow , sameArgIdempotentCommut WordOrOp+ , orFoldingRules wordOps ] WordXorOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor) , identityPlatform zerow@@ -479,6 +524,33 @@ WordSllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord (const shiftL) ] WordSrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord shiftRightLogicalNative ] + PopCnt8Op -> mkPrimOpRule nm 1 [ pop_count @Word8 ]+ PopCnt16Op -> mkPrimOpRule nm 1 [ pop_count @Word16 ]+ PopCnt32Op -> mkPrimOpRule nm 1 [ pop_count @Word32 ]+ PopCnt64Op -> mkPrimOpRule nm 1 [ pop_count @Word64 ]+ PopCntOp -> mkPrimOpRule nm 1 [ getWordSize >>= \case+ PW4 -> pop_count @Word32+ PW8 -> pop_count @Word64+ ]++ Ctz8Op -> mkPrimOpRule nm 1 [ ctz @Word8 ]+ Ctz16Op -> mkPrimOpRule nm 1 [ ctz @Word16 ]+ Ctz32Op -> mkPrimOpRule nm 1 [ ctz @Word32 ]+ Ctz64Op -> mkPrimOpRule nm 1 [ ctz @Word64 ]+ CtzOp -> mkPrimOpRule nm 1 [ getWordSize >>= \case+ PW4 -> ctz @Word32+ PW8 -> ctz @Word64+ ]++ Clz8Op -> mkPrimOpRule nm 1 [ clz @Word8 ]+ Clz16Op -> mkPrimOpRule nm 1 [ clz @Word16 ]+ Clz32Op -> mkPrimOpRule nm 1 [ clz @Word32 ]+ Clz64Op -> mkPrimOpRule nm 1 [ clz @Word64 ]+ ClzOp -> mkPrimOpRule nm 1 [ getWordSize >>= \case+ PW4 -> clz @Word32+ PW8 -> clz @Word64+ ]+ -- coercions Int8ToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ]@@ -486,13 +558,10 @@ Int32ToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ] Int64ToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ] IntToInt8Op -> mkPrimOpRule nm 1 [ liftLit narrowInt8Lit- , semiInversePrimOp Int8ToIntOp , narrowSubsumesAnd IntAndOp IntToInt8Op 8 ] IntToInt16Op -> mkPrimOpRule nm 1 [ liftLit narrowInt16Lit- , semiInversePrimOp Int16ToIntOp , narrowSubsumesAnd IntAndOp IntToInt16Op 16 ] IntToInt32Op -> mkPrimOpRule nm 1 [ liftLit narrowInt32Lit- , semiInversePrimOp Int32ToIntOp , narrowSubsumesAnd IntAndOp IntToInt32Op 32 ] IntToInt64Op -> mkPrimOpRule nm 1 [ liftLit narrowInt64Lit ] @@ -508,37 +577,24 @@ Word64ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit ] WordToWord8Op -> mkPrimOpRule nm 1 [ liftLit narrowWord8Lit- , semiInversePrimOp Word8ToWordOp , narrowSubsumesAnd WordAndOp WordToWord8Op 8 ] WordToWord16Op -> mkPrimOpRule nm 1 [ liftLit narrowWord16Lit- , semiInversePrimOp Word16ToWordOp , narrowSubsumesAnd WordAndOp WordToWord16Op 16 ] WordToWord32Op -> mkPrimOpRule nm 1 [ liftLit narrowWord32Lit- , semiInversePrimOp Word32ToWordOp , narrowSubsumesAnd WordAndOp WordToWord32Op 32 ] WordToWord64Op -> mkPrimOpRule nm 1 [ liftLit narrowWord64Lit ] - Word8ToInt8Op -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt8)- , semiInversePrimOp Int8ToWord8Op ]- Int8ToWord8Op -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord8)- , semiInversePrimOp Word8ToInt8Op ]- Word16ToInt16Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt16)- , semiInversePrimOp Int16ToWord16Op ]- Int16ToWord16Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord16)- , semiInversePrimOp Word16ToInt16Op ]- Word32ToInt32Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt32)- , semiInversePrimOp Int32ToWord32Op ]- Int32ToWord32Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord32)- , semiInversePrimOp Word32ToInt32Op ]- Word64ToInt64Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt64)- , semiInversePrimOp Int64ToWord64Op ]- Int64ToWord64Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord64)- , semiInversePrimOp Word64ToInt64Op ]+ Word8ToInt8Op -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt8) ]+ Int8ToWord8Op -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord8) ]+ Word16ToInt16Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt16) ]+ Int16ToWord16Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord16) ]+ Word32ToInt32Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt32) ]+ Int32ToWord32Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord32) ]+ Word64ToInt64Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt64) ]+ Int64ToWord64Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord64) ] - WordToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt)- , semiInversePrimOp IntToWordOp ]- IntToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord)- , semiInversePrimOp WordToIntOp ]+ WordToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt) ]+ IntToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord) ] Narrow8IntOp -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumInt8) , subsumedByPrimOp Narrow8IntOp@@ -1410,12 +1466,12 @@ getPlatform :: RuleM Platform getPlatform = roPlatform <$> getRuleOpts +getWordSize :: RuleM PlatformWordSize+getWordSize = platformWordSize <$> getPlatform+ getRuleOpts :: RuleM RuleOpts getRuleOpts = RuleM $ \rule_opts _ _ _ -> Just rule_opts -getEnv :: RuleM InScopeEnv-getEnv = RuleM $ \_ env _ _ -> Just env- liftMaybe :: Maybe a -> RuleM a liftMaybe Nothing = mzero liftMaybe (Just x) = return x@@ -1448,20 +1504,6 @@ getFunction :: RuleM Id getFunction = RuleM $ \_ _ fn _ -> Just fn -exprIsVarApp_maybe :: InScopeEnv -> CoreExpr -> Maybe (Id,CoreArg)-exprIsVarApp_maybe env@(_, id_unf) e = case e of- App (Var f) a -> Just (f, a)- Var v- | Just rhs <- expandUnfolding_maybe (id_unf v)- -> exprIsVarApp_maybe env rhs- _ -> Nothing---- | Looks into the expression or its unfolding to find "App (Var f) x"-isVarApp :: InScopeEnv -> CoreExpr -> RuleM (Id,CoreArg)-isVarApp env e = case exprIsVarApp_maybe env e of- Nothing -> mzero- Just r -> pure r- isLiteral :: CoreExpr -> RuleM Literal isLiteral e = do env <- getInScopeEnv@@ -1469,30 +1511,52 @@ Nothing -> mzero Just l -> pure l +-- | Match Integer and Natural literals+isBignumLiteral :: CoreExpr -> RuleM Integer+isBignumLiteral e = isIntegerLiteral e <|> isNaturalLiteral e++-- | Match numeric literals isNumberLiteral :: CoreExpr -> RuleM Integer isNumberLiteral e = isLiteral e >>= \case LitNumber _ x -> pure x _ -> mzero -isIntegerLiteral :: CoreExpr -> RuleM Integer-isIntegerLiteral e = isLiteral e >>= \case- LitNumber LitNumInteger x -> pure x- _ -> mzero+-- | Match the application of a DataCon to a numeric literal.+--+-- Can be used to match e.g.:+-- IS 123#+-- IP bigNatLiteral+-- W# 123##+isLitNumConApp :: CoreExpr -> RuleM (DataCon,Integer)+isLitNumConApp e = do+ env <- getInScopeEnv+ case exprIsConApp_maybe env e of+ Just (_env,_fb,dc,_tys,[arg]) -> case exprIsLiteral_maybe env arg of+ Just (LitNumber _ i) -> pure (dc,i)+ _ -> mzero+ _ -> mzero -isNaturalLiteral :: CoreExpr -> RuleM Integer-isNaturalLiteral e = isLiteral e >>= \case- LitNumber LitNumNatural x -> pure x- _ -> mzero+isIntegerLiteral :: CoreExpr -> RuleM Integer+isIntegerLiteral e = do+ (dc,i) <- isLitNumConApp e+ if | dc == integerISDataCon -> pure i+ | dc == integerINDataCon -> pure (negate i)+ | dc == integerIPDataCon -> pure i+ | otherwise -> mzero -isWordLiteral :: CoreExpr -> RuleM Integer-isWordLiteral e = isLiteral e >>= \case- LitNumber LitNumWord x -> pure x- _ -> mzero+isBigIntegerLiteral :: CoreExpr -> RuleM Integer+isBigIntegerLiteral e = do+ (dc,i) <- isLitNumConApp e+ if | dc == integerINDataCon -> pure (negate i)+ | dc == integerIPDataCon -> pure i+ | otherwise -> mzero -isIntLiteral :: CoreExpr -> RuleM Integer-isIntLiteral e = isLiteral e >>= \case- LitNumber LitNumInt x -> pure x- _ -> mzero+isNaturalLiteral :: CoreExpr -> RuleM Integer+isNaturalLiteral e = do+ (dc,i) <- isLitNumConApp e+ if | dc == naturalNSDataCon -> pure i+ | dc == naturalNBDataCon -> pure i+ | otherwise -> mzero -- return the n-th argument of this rule, if it is a literal -- argument indices start from 0@@ -1597,6 +1661,21 @@ oneLit :: Int -> RuleM () oneLit n = getLiteral n >>= guard . isOneLit +lift_bits_op :: forall a. (Num a, FiniteBits a) => (a -> Integer) -> RuleM CoreExpr+lift_bits_op op = do+ platform <- getPlatform+ [Lit (LitNumber _ l)] <- getArgs+ pure $ mkWordLit platform $ op (fromInteger l :: a)++pop_count :: forall a. (Num a, FiniteBits a) => RuleM CoreExpr+pop_count = lift_bits_op @a (fromIntegral . popCount)++ctz :: forall a. (Num a, FiniteBits a) => RuleM CoreExpr+ctz = lift_bits_op @a (fromIntegral . countTrailingZeros)++clz :: forall a. (Num a, FiniteBits a) => RuleM CoreExpr+clz = lift_bits_op @a (fromIntegral . countLeadingZeros)+ -- When excess precision is not requested, cut down the precision of the -- Rational value to that of Float/Double. We confuse host architecture -- and target architecture here, but it's convenient (and wrong :-).@@ -1970,7 +2049,6 @@ , integer_to_natural "Integer -> Natural (wrap)" integerToNaturalName False False , integer_to_natural "Integer -> Natural (throw)" integerToNaturalThrowName True False - , lit_to_natural "Word# -> Natural" naturalNSName , natural_to_word "Natural -> Word# (wrap)" naturalToWordName False , natural_to_word "Natural -> Word# (clamp)" naturalToWordClampName True @@ -2021,17 +2099,18 @@ y <- isNaturalLiteral a1 -- return an unboxed sum: (# (# #) | Natural #) let ret n v = pure $ mkCoreUbxSum 2 n [unboxedUnitTy,naturalTy] v+ platform <- getPlatform if x < y then ret 1 $ Var voidPrimId- else ret 2 $ Lit (mkLitNatural (x - y))+ else ret 2 $ mkNaturalExpr platform (x - y) -- unary operations- , bignum_unop "integerNegate" integerNegateName mkLitInteger negate- , bignum_unop "integerAbs" integerAbsName mkLitInteger abs- , bignum_unop "integerSignum" integerSignumName mkLitInteger signum- , bignum_unop "integerComplement" integerComplementName mkLitInteger complement+ , bignum_unop "integerNegate" integerNegateName mkIntegerExpr negate+ , bignum_unop "integerAbs" integerAbsName mkIntegerExpr abs+ , bignum_unop "integerSignum" integerSignumName mkIntegerExpr signum+ , bignum_unop "integerComplement" integerComplementName mkIntegerExpr complement - , bignum_unop "naturalSignum" naturalSignumName mkLitNatural signum+ , bignum_unop "naturalSignum" naturalSignumName mkNaturalExpr signum , mkRule "naturalNegate" naturalNegateName 1 $ do [a0] <- getArgs@@ -2050,108 +2129,31 @@ -- See Note [Optimising conversions between numeric types] -- - , small_passthrough_id "Word# -> Natural -> Word#"- naturalNSName naturalToWordName- , small_passthrough_id "Word# -> Natural -> Word# (clamp)"- naturalNSName naturalToWordClampName-- , small_passthrough_id "Int# -> Integer -> Int#"- integerISName integerToIntName- , small_passthrough_id "Word# -> Integer -> Word#"- integerFromWordName integerToWordName- , small_passthrough_id "Int64# -> Integer -> Int64#"- integerFromInt64Name integerToInt64Name- , small_passthrough_id "Word64# -> Integer -> Word64#"- integerFromWord64Name integerToWord64Name- , small_passthrough_id "Natural -> Integer -> Natural (wrap)"- integerFromNaturalName integerToNaturalName- , small_passthrough_id "Natural -> Integer -> Natural (throw)"- integerFromNaturalName integerToNaturalThrowName- , small_passthrough_id "Natural -> Integer -> Natural (clamp)"- integerFromNaturalName integerToNaturalClampName-- , small_passthrough_app "Int# -> Integer -> Word#"- integerISName integerToWordName (mkPrimOpId IntToWordOp)- , small_passthrough_app "Int# -> Integer -> Float#"- integerISName integerToFloatName (mkPrimOpId IntToFloatOp)- , small_passthrough_app "Int# -> Integer -> Double#"- integerISName integerToDoubleName (mkPrimOpId IntToDoubleOp)-- , small_passthrough_app "Word# -> Integer -> Int#"- integerFromWordName integerToIntName (mkPrimOpId WordToIntOp)- , small_passthrough_app "Word# -> Integer -> Float#"- integerFromWordName integerToFloatName (mkPrimOpId WordToFloatOp)- , small_passthrough_app "Word# -> Integer -> Double#"- integerFromWordName integerToDoubleName (mkPrimOpId WordToDoubleOp)- , small_passthrough_app "Word# -> Integer -> Natural (wrap)"- integerFromWordName integerToNaturalName naturalNSId- , small_passthrough_app "Word# -> Integer -> Natural (throw)"- integerFromWordName integerToNaturalThrowName naturalNSId- , small_passthrough_app "Word# -> Integer -> Natural (clamp)"- integerFromWordName integerToNaturalClampName naturalNSId-- , small_passthrough_app "Word# -> Natural -> Float#"- naturalNSName naturalToFloatName (mkPrimOpId WordToFloatOp)- , small_passthrough_app "Word# -> Natural -> Double#"- naturalNSName naturalToDoubleName (mkPrimOpId WordToDoubleOp)-- , small_passthrough_id "Int64# -> Integer -> Int64#"- integerFromInt64Name integerToInt64Name- , small_passthrough_id "Word64# -> Integer -> Word64#"- integerFromWord64Name integerToWord64Name-- , small_passthrough_app "Int64# -> Integer -> Word64#"- integerFromInt64Name integerToWord64Name (mkPrimOpId Int64ToWord64Op)- , small_passthrough_app "Word64# -> Integer -> Int64#"- integerFromWord64Name integerToInt64Name (mkPrimOpId Word64ToInt64Op)-- , small_passthrough_app "Word# -> Integer -> Word64#"- integerFromWordName integerToWord64Name (mkPrimOpId WordToWord64Op)- , small_passthrough_app "Word64# -> Integer -> Word#"- integerFromWord64Name integerToWordName (mkPrimOpId Word64ToWordOp)- , small_passthrough_app "Int# -> Integer -> Int64#"- integerISName integerToInt64Name (mkPrimOpId IntToInt64Op)- , small_passthrough_app "Int64# -> Integer -> Int#"- integerFromInt64Name integerToIntName (mkPrimOpId Int64ToIntOp)-- , small_passthrough_custom "Int# -> Integer -> Word64#"- integerISName integerToWord64Name- (\x -> Var (mkPrimOpId Int64ToWord64Op) `App` (Var (mkPrimOpId IntToInt64Op) `App` x))- , small_passthrough_custom "Word64# -> Integer -> Int#"- integerFromWord64Name integerToIntName- (\x -> Var (mkPrimOpId WordToIntOp) `App` (Var (mkPrimOpId Word64ToWordOp) `App` x))- , small_passthrough_custom "Word# -> Integer -> Int64#"- integerFromWordName integerToInt64Name- (\x -> Var (mkPrimOpId Word64ToInt64Op) `App` (Var (mkPrimOpId WordToWord64Op) `App` x))- , small_passthrough_custom "Int64# -> Integer -> Word#"- integerFromInt64Name integerToWordName- (\x -> Var (mkPrimOpId IntToWordOp) `App` (Var (mkPrimOpId Int64ToIntOp) `App` x))- -- Bits.bit- , bignum_bit "integerBit" integerBitName mkLitInteger- , bignum_bit "naturalBit" naturalBitName mkLitNatural+ , bignum_bit "integerBit" integerBitName mkIntegerExpr+ , bignum_bit "naturalBit" naturalBitName mkNaturalExpr -- Bits.testBit , bignum_testbit "integerTestBit" integerTestBitName , bignum_testbit "naturalTestBit" naturalTestBitName -- Bits.shift- , bignum_shift "integerShiftL" integerShiftLName shiftL mkLitInteger- , bignum_shift "integerShiftR" integerShiftRName shiftR mkLitInteger- , bignum_shift "naturalShiftL" naturalShiftLName shiftL mkLitNatural- , bignum_shift "naturalShiftR" naturalShiftRName shiftR mkLitNatural+ , bignum_shift "integerShiftL" integerShiftLName shiftL mkIntegerExpr+ , bignum_shift "integerShiftR" integerShiftRName shiftR mkIntegerExpr+ , bignum_shift "naturalShiftL" naturalShiftLName shiftL mkNaturalExpr+ , bignum_shift "naturalShiftR" naturalShiftRName shiftR mkNaturalExpr -- division- , divop_one "integerQuot" integerQuotName quot mkLitInteger- , divop_one "integerRem" integerRemName rem mkLitInteger- , divop_one "integerDiv" integerDivName div mkLitInteger- , divop_one "integerMod" integerModName mod mkLitInteger- , divop_both "integerDivMod" integerDivModName divMod mkLitInteger integerTy- , divop_both "integerQuotRem" integerQuotRemName quotRem mkLitInteger integerTy+ , divop_one "integerQuot" integerQuotName quot mkIntegerExpr+ , divop_one "integerRem" integerRemName rem mkIntegerExpr+ , divop_one "integerDiv" integerDivName div mkIntegerExpr+ , divop_one "integerMod" integerModName mod mkIntegerExpr+ , divop_both "integerDivMod" integerDivModName divMod mkIntegerExpr integerTy+ , divop_both "integerQuotRem" integerQuotRemName quotRem mkIntegerExpr integerTy - , divop_one "naturalQuot" naturalQuotName quot mkLitNatural- , divop_one "naturalRem" naturalRemName rem mkLitNatural- , divop_both "naturalQuotRem" naturalQuotRemName quotRem mkLitNatural naturalTy+ , divop_one "naturalQuot" naturalQuotName quot mkNaturalExpr+ , divop_one "naturalRem" naturalRemName rem mkNaturalExpr+ , divop_both "naturalQuotRem" naturalQuotRemName quotRem mkNaturalExpr naturalTy -- conversions from Rational for Float/Double literals , rational_to "rationalToFloat" rationalToFloatName mkFloatExpr@@ -2162,27 +2164,6 @@ , integer_encode_float "integerEncodeDouble" integerEncodeDoubleName mkDoubleLitDouble ] where- -- The rule is matching against an occurrence of a data constructor in a- -- Core expression. It must match either its worker name or its wrapper- -- name, /not/ the DataCon name itself, which is different.- -- See Note [Data Constructor Naming] in GHC.Core.DataCon and #19892- --- -- But data constructor wrappers deliberately inline late; See Note- -- [Activation for data constructor wrappers] in GHC.Types.Id.Make.- -- Suppose there is a wrapper and the rule matches on the worker: the- -- wrapper won't be inlined until rules have finished firing and the rule- -- will never fire.- --- -- Hence the rule must match on the wrapper, if there is one, otherwise on- -- the worker. That is exactly the dataConWrapId for the data constructor.- -- The data constructor may or may not have a wrapper, but if not- -- dataConWrapId will return the worker- --- integerISId = dataConWrapId integerISDataCon- naturalNSId = dataConWrapId naturalNSDataCon- integerISName = idName integerISId- naturalNSName = idName naturalNSId- mkRule str name nargs f = BuiltinRule { ru_name = fsLit str , ru_fn = name@@ -2196,7 +2177,9 @@ integer_to_lit str name convert = mkRule str name 1 $ do [a0] <- getArgs platform <- getPlatform- x <- isIntegerLiteral a0+ -- we only match on Big Integer literals. Small literals+ -- are matched by the "Int# -> Integer -> *" rules+ x <- isBigIntegerLiteral a0 pure (convert platform x) natural_to_word str name clamp = mkRule str name 1 $ do@@ -2210,43 +2193,40 @@ integer_to_natural str name thrw clamp = mkRule str name 1 $ do [a0] <- getArgs x <- isIntegerLiteral a0- if | x >= 0 -> pure $ Lit $ mkLitNatural x+ platform <- getPlatform+ if | x >= 0 -> pure $ mkNaturalExpr platform x | thrw -> mzero- | clamp -> pure $ Lit $ mkLitNatural 0 -- clamp to 0- | otherwise -> pure $ Lit $ mkLitNatural (abs x) -- negate/wrap+ | clamp -> pure $ mkNaturalExpr platform 0 -- clamp to 0+ | otherwise -> pure $ mkNaturalExpr platform (abs x) -- negate/wrap lit_to_integer str name = mkRule str name 1 $ do [a0] <- getArgs- isLiteral a0 >>= \case- -- convert any numeric literal into an Integer literal- LitNumber _ i -> pure (Lit (mkLitInteger i))- _ -> mzero-- lit_to_natural str name = mkRule str name 1 $ do- [a0] <- getArgs- isLiteral a0 >>= \case- -- convert any *positive* numeric literal into a Natural literal- LitNumber _ i | i >= 0 -> pure (Lit (mkLitNatural i))- _ -> mzero+ platform <- getPlatform+ i <- isNumberLiteral a0 <|> isBignumLiteral a0+ -- convert any numeric literal into an Integer literal+ pure (mkIntegerExpr platform i) integer_binop str name op = mkRule str name 2 $ do [a0,a1] <- getArgs x <- isIntegerLiteral a0 y <- isIntegerLiteral a1- pure (Lit (mkLitInteger (x `op` y)))+ platform <- getPlatform+ pure (mkIntegerExpr platform (x `op` y)) natural_binop str name op = mkRule str name 2 $ do [a0,a1] <- getArgs x <- isNaturalLiteral a0 y <- isNaturalLiteral a1- pure (Lit (mkLitNatural (x `op` y)))+ platform <- getPlatform+ pure (mkNaturalExpr platform (x `op` y)) natural_sub str name = mkRule str name 2 $ do [a0,a1] <- getArgs x <- isNaturalLiteral a0 y <- isNaturalLiteral a1 guard (x >= y)- pure (Lit (mkLitNatural (x - y)))+ platform <- getPlatform+ pure (mkNaturalExpr platform (x - y)) integer_cmp str name op = mkRule str name 2 $ do platform <- getPlatform@@ -2268,8 +2248,8 @@ bignum_compare str name = mkRule str name 2 $ do [a0,a1] <- getArgs- x <- isNumberLiteral a0- y <- isNumberLiteral a1+ x <- isBignumLiteral a0+ y <- isBignumLiteral a1 pure $ case x `compare` y of LT -> ltVal EQ -> eqVal@@ -2277,8 +2257,9 @@ bignum_unop str name mk_lit op = mkRule str name 1 $ do [a0] <- getArgs- x <- isNumberLiteral a0- pure $ Lit (mk_lit (op x))+ x <- isBignumLiteral a0+ platform <- getPlatform+ pure $ mk_lit platform (op x) bignum_popcount str name mk_lit = mkRule str name 1 $ do platform <- getPlatform@@ -2287,22 +2268,9 @@ -- by the target. So we disable this rule if sizes don't match. guard (platformWordSizeInBits platform == finiteBitSize (0 :: Word)) [a0] <- getArgs- x <- isNumberLiteral a0+ x <- isBignumLiteral a0 pure $ Lit (mk_lit platform (fromIntegral (popCount x))) - small_passthrough_id str from_x to_x =- small_passthrough_custom str from_x to_x id-- small_passthrough_app str from_x to_y x_to_y =- small_passthrough_custom str from_x to_y (App (Var x_to_y))-- small_passthrough_custom str from_x to_y x_to_y = mkRule str to_y 1 $ do- [a0] <- getArgs- env <- getEnv- (f,x) <- isVarApp env a0- guard (idName f == from_x)- pure $ x_to_y x- bignum_bit str name mk_lit = mkRule str name 1 $ do [a0] <- getArgs platform <- getPlatform@@ -2314,12 +2282,12 @@ guard (n >= 0 && n <= fromIntegral (platformWordSizeInBits platform)) -- it's safe to convert a target Int value into a host Int value -- to perform the "bit" operation because n is very small (<= 64).- pure $ Lit (mk_lit (bit (fromIntegral n)))+ pure $ mk_lit platform (bit (fromIntegral n)) bignum_testbit str name = mkRule str name 2 $ do [a0,a1] <- getArgs platform <- getPlatform- x <- isNumberLiteral a0+ x <- isBignumLiteral a0 n <- isNumberLiteral a1 -- ensure that we can store 'n' in a host Int guard (n >= 0 && n <= fromIntegral (maxBound :: Int))@@ -2329,34 +2297,37 @@ bignum_shift str name shift_op mk_lit = mkRule str name 2 $ do [a0,a1] <- getArgs- x <- isNumberLiteral a0- n <- isWordLiteral a1+ x <- isBignumLiteral a0+ n <- isNumberLiteral a1 -- See Note [Guarding against silly shifts] -- Restrict constant-folding of shifts on Integers, somewhat arbitrary. -- We can get huge shifts in inaccessible code (#15673) guard (n <= 4)- pure $ Lit (mk_lit (x `shift_op` fromIntegral n))+ platform <- getPlatform+ pure $ mk_lit platform (x `shift_op` fromIntegral n) divop_one str name divop mk_lit = mkRule str name 2 $ do [a0,a1] <- getArgs- n <- isNumberLiteral a0- d <- isNumberLiteral a1+ n <- isBignumLiteral a0+ d <- isBignumLiteral a1 guard (d /= 0)- pure $ Lit (mk_lit (n `divop` d))+ platform <- getPlatform+ pure $ mk_lit platform (n `divop` d) divop_both str name divop mk_lit ty = mkRule str name 2 $ do [a0,a1] <- getArgs- n <- isNumberLiteral a0- d <- isNumberLiteral a1+ n <- isBignumLiteral a0+ d <- isBignumLiteral a1 guard (d /= 0) let (r,s) = n `divop` d- pure $ mkCoreUbxTup [ty,ty] [Lit (mk_lit r), Lit (mk_lit s)]+ platform <- getPlatform+ pure $ mkCoreUbxTup [ty,ty] [mk_lit platform r, mk_lit platform s] integer_encode_float :: RealFloat a => String -> Name -> (a -> CoreExpr) -> CoreRule integer_encode_float str name mk_lit = mkRule str name 2 $ do [a0,a1] <- getArgs x <- isIntegerLiteral a0- y <- isIntLiteral a1+ y <- isNumberLiteral a1 -- check that y (a target Int) is in the host Int range guard (y <= fromIntegral (maxBound :: Int)) pure (mk_lit $ encodeFloat x (fromInteger y))@@ -2609,8 +2580,8 @@ -- B: (10+x) + 5 ==> 15+x -- C: (5+a)-(5-b) ==> 0+(a+b) ----- R2) * simplification--- ops = *, two literals (not siblings)+-- R2) *, `and`, `or` simplification+-- ops = *, `and`, `or` two literals (not siblings) -- -- Examples: -- A: 5 * (10*x) ==> 50*x@@ -2694,7 +2665,28 @@ (mulFoldingRules' platform arg1 arg2 num_ops <|> mulFoldingRules' platform arg2 arg1 num_ops) +andFoldingRules :: NumOps -> RuleM CoreExpr+andFoldingRules num_ops = do+ env <- getRuleOpts+ guard (roNumConstantFolding env)+ [arg1,arg2] <- getArgs+ platform <- getPlatform+ liftMaybe+ -- commutativity for `and` is handled here+ (andFoldingRules' platform arg1 arg2 num_ops+ <|> andFoldingRules' platform arg2 arg1 num_ops) +orFoldingRules :: NumOps -> RuleM CoreExpr+orFoldingRules num_ops = do+ env <- getRuleOpts+ guard (roNumConstantFolding env)+ [arg1,arg2] <- getArgs+ platform <- getPlatform+ liftMaybe+ -- commutativity for `or` is handled here+ (orFoldingRules' platform arg1 arg2 num_ops+ <|> orFoldingRules' platform arg2 arg1 num_ops)+ addFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr addFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of -- R1) +/- simplification@@ -2922,29 +2914,76 @@ sub x y = BinOpApp x (numSub num_ops) y mul x y = BinOpApp x (numMul num_ops) y +andFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr+andFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of+ -- R2) * `or` `and` simplications+ -- l1 and (l2 and x) ==> (l1 and l2) and x+ (L l1, is_lit_and num_ops -> Just (l2, x))+ -> Just (mkL (l1 .&. l2) `and` x)++ -- l1 and (l2 or x) ==> (l1 and l2) or (l1 and x)+ -- does not decrease operations++ -- (l1 and x) and (l2 and y) ==> (l1 and l2) and (x and y)+ (is_lit_and num_ops -> Just (l1, x), is_lit_and num_ops -> Just (l2, y))+ -> Just (mkL (l1 .&. l2) `and` (x `and` y))++ -- (l1 and x) and (l2 or y) ==> (l1 and l2 and x) or (l1 and x and y)+ -- (l1 or x) and (l2 or y) ==> (l1 and l2) or (x and l2) or (l1 and y) or (x and y)+ -- increase operation numbers++ _ -> Nothing+ where+ mkL = Lit . mkNumLiteral platform num_ops+ and x y = BinOpApp x (fromJust (numAnd num_ops)) y++orFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr+orFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of+ -- R2) * `or` `and` simplications+ -- l1 or (l2 or x) ==> (l1 or l2) or x+ (L l1, is_lit_or num_ops -> Just (l2, x))+ -> Just (mkL (l1 .|. l2) `or` x)++ -- l1 or (l2 and x) ==> (l1 or l2) and (l1 and x)+ -- does not decrease operations++ -- (l1 or x) or (l2 or y) ==> (l1 or l2) or (x or y)+ (is_lit_or num_ops -> Just (l1, x), is_lit_or num_ops -> Just (l2, y))+ -> Just (mkL (l1 .|. l2) `or` (x `or` y))++ -- (l1 and x) or (l2 or y) ==> (l1 and l2 and x) or (l1 and x and y)+ -- (l1 and x) or (l2 and y) ==> (l1 and l2) or (x and l2) or (l1 and y) or (x and y)+ -- increase operation numbers++ _ -> Nothing+ where+ mkL = Lit . mkNumLiteral platform num_ops+ or x y = BinOpApp x (fromJust (numOr num_ops)) y+ is_op :: PrimOp -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr) is_op op e = case e of BinOpApp x op' y | op == op' -> Just (x,y) _ -> Nothing -is_add, is_sub, is_mul :: NumOps -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr)+is_add, is_sub, is_mul, is_and, is_or :: NumOps -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr) is_add num_ops = is_op (numAdd num_ops) is_sub num_ops = is_op (numSub num_ops) is_mul num_ops = is_op (numMul num_ops)+is_and num_ops = is_op (fromJust (numAnd num_ops))+is_or num_ops = is_op (fromJust (numOr num_ops)) --- match addition with a literal (handles commutativity)-is_lit_add :: NumOps -> CoreExpr -> Maybe (Integer, Arg CoreBndr)-is_lit_add num_ops e = case is_add num_ops e of- Just (L l, x ) -> Just (l,x)- Just (x , L l) -> Just (l,x)- _ -> Nothing+-- match operation with a literal (handles commutativity)+is_lit_add, is_lit_mul, is_lit_and, is_lit_or :: NumOps -> CoreExpr -> Maybe (Integer, Arg CoreBndr)+is_lit_add num_ops e = is_lit' is_add num_ops e+is_lit_mul num_ops e = is_lit' is_mul num_ops e+is_lit_and num_ops e = is_lit' is_and num_ops e+is_lit_or num_ops e = is_lit' is_or num_ops e --- match multiplication with a literal (handles commutativity)-is_lit_mul :: NumOps -> CoreExpr -> Maybe (Integer, Arg CoreBndr)-is_lit_mul num_ops e = case is_mul num_ops e of- Just (L l, x ) -> Just (l,x)- Just (x , L l) -> Just (l,x)- _ -> Nothing+is_lit' :: (NumOps -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr)) -> NumOps -> CoreExpr -> Maybe (Integer, Arg CoreBndr)+is_lit' f num_ops e = case f num_ops e of+ Just (L l, x ) -> Just (l,x)+ Just (x , L l) -> Just (l,x)+ _ -> Nothing -- match given "x": return 1 -- match "lit * x": return lit value (handles commutativity)@@ -2978,6 +3017,8 @@ , numSub :: !PrimOp -- ^ Sub two numbers , numMul :: !PrimOp -- ^ Multiply two numbers , numLitType :: !LitNumType -- ^ Literal type+ , numAnd :: !(Maybe PrimOp) -- ^ And two numbers+ , numOr :: !(Maybe PrimOp) -- ^ Or two numbers } -- | Create a numeric literal@@ -2990,6 +3031,8 @@ , numSub = Int8SubOp , numMul = Int8MulOp , numLitType = LitNumInt8+ , numAnd = Nothing+ , numOr = Nothing } word8Ops :: NumOps@@ -2997,6 +3040,8 @@ { numAdd = Word8AddOp , numSub = Word8SubOp , numMul = Word8MulOp+ , numAnd = Just Word8AndOp+ , numOr = Just Word8OrOp , numLitType = LitNumWord8 } @@ -3006,6 +3051,8 @@ , numSub = Int16SubOp , numMul = Int16MulOp , numLitType = LitNumInt16+ , numAnd = Nothing+ , numOr = Nothing } word16Ops :: NumOps@@ -3013,6 +3060,8 @@ { numAdd = Word16AddOp , numSub = Word16SubOp , numMul = Word16MulOp+ , numAnd = Just Word16AndOp+ , numOr = Just Word16OrOp , numLitType = LitNumWord16 } @@ -3022,6 +3071,8 @@ , numSub = Int32SubOp , numMul = Int32MulOp , numLitType = LitNumInt32+ , numAnd = Nothing+ , numOr = Nothing } word32Ops :: NumOps@@ -3029,6 +3080,8 @@ { numAdd = Word32AddOp , numSub = Word32SubOp , numMul = Word32MulOp+ , numAnd = Just Word32AndOp+ , numOr = Just Word32OrOp , numLitType = LitNumWord32 } @@ -3038,6 +3091,8 @@ , numSub = Int64SubOp , numMul = Int64MulOp , numLitType = LitNumInt64+ , numAnd = Nothing+ , numOr = Nothing } word64Ops :: NumOps@@ -3045,6 +3100,8 @@ { numAdd = Word64AddOp , numSub = Word64SubOp , numMul = Word64MulOp+ , numAnd = Just Word64AndOp+ , numOr = Just Word64OrOp , numLitType = LitNumWord64 } @@ -3053,6 +3110,8 @@ { numAdd = IntAddOp , numSub = IntSubOp , numMul = IntMulOp+ , numAnd = Just IntAndOp+ , numOr = Just IntOrOp , numLitType = LitNumInt } @@ -3061,6 +3120,8 @@ { numAdd = WordAddOp , numSub = WordSubOp , numMul = WordMulOp+ , numAnd = Just WordAndOp+ , numOr = Just WordOrOp , numLitType = LitNumWord } @@ -3267,126 +3328,4 @@ an alternative that is unreachable. You may wonder how this can happen: check out #15436.---Note [Optimising conversions between numeric types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Converting between numeric types is very common in Haskell codes. Suppose that-we have N inter-convertible numeric types (Word, Word8, Int, Integer, etc.).--- We don't want to have to use one conversion function per pair of types as that-would require N^2 functions: wordToWord8, wordToInt, wordToInteger...--- The following kind of class would allow us to have a single conversion-function at the price of N^2 instances and of the use of MultiParamTypeClasses-extension.-- class Convert a b where- convert :: a -> b--What we do instead is that we use the Integer type (signed, unbounded) as a-passthrough type to perform every conversion. Hence we only need to define two-functions per numeric type:-- class Integral a where- toInteger :: a -> Integer-- class Num a where- fromInteger :: Integer -> a--These classes have a single parameter and can be derived automatically (e.g. for-newtypes). So we don't even have to define 2*N instances.--fromIntegral---------------We can now define a generic conversion function:-- -- in the Prelude- fromIntegral :: (Integral a, Num b) => a -> b- fromIntegral = fromInteger . toInteger--The trouble with this approach is that performance might be terrible. E.g.-converting an Int into a Word, which is a no-op at the machine level, becomes-costly when performed via `fromIntegral` because an Integer has to be allocated.--To alleviate this:--- first `fromIntegral` was specialized (SPECIALIZE pragma). However it would-need N^2 pragmas to cover every case and it wouldn't cover user defined numeric-types which don't belong to base.--- while writing this note I discovered that we have a `-fwarn-identities` warning-to detect useless conversions (since 0656c72a8f):-- > fromIntegral (1 :: Int) :: Int-- <interactive>:3:21: warning: [-Widentities]- Call of fromIntegral :: Int -> Int- can probably be omitted--- but more importantly, many rules were added (e.g. in e0c787c10f):-- "fromIntegral/Int8->Int8" fromIntegral = id :: Int8 -> Int8- "fromIntegral/a->Int8" fromIntegral = \x -> case fromIntegral x of I# x# -> I8# (intToInt8# x#)- "fromIntegral/Int8->a" fromIntegral = \(I8# x#) -> fromIntegral (I# x#)-- The idea was to ensure that only cheap conversions ended up being used. E.g.:-- foo :: Int8 --> {- Integer -> -} -> Word8- foo = fromIntegral-- ====> {Some fromIntegral rule for Int8}-- foo :: Int8 -> {- Int -> Integer -} -> Word8- foo = fromIntegral . int8ToInt-- ====> {Some fromIntegral rule for Word8}-- foo :: Int8 -> {- Int -> Integer -> Word -} -> Word8- foo = wordToWord8 . fromIntegral . int8ToInt-- ====> {Some fromIntegral rule for Int/Word}-- foo :: Int8 -> {- Int -> Word -} -> Word8- foo = wordToWord8 . intToWord . int8ToInt- -- not passing through Integer anymore!---It worked but there were still some issues with this approach:--1. These rules only work for `fromIntegral`. If we wanted to define our own- similar function (e.g. using other type-classes), we would also have to redefine- all the rules to get similar performance.--2. `fromIntegral` had to be marked `NOINLINE [1]`:- - NOINLINE to allow rules to match- - [1] to allow inlining in later phases to avoid incurring a function call- overhead for such a trivial operation-- Users of the function had to be careful because a simple helper without an- INLINE pragma like:-- toInt :: Integral a => a -> Int- toInt = fromIntegral-- has the following unfolding:-- toInt = integerToInt . toInteger-- which doesn't mention `fromIntegral` anymore. Hence `fromIntegral` rules- wouldn't be triggered for any user of `toInt`. For this reason, we also have- a bunch of rules for bignum primitives such as `integerToInt`.--3. These rewrite rules are tedious to write and error-prone (cf #19345).---For these reasons, it is simpler to only rely on built-in rewrite rules for-bignum primitives. There aren't so many conversion primitives:- - Natural <-> Word- - Integer <-> Int/Word/Natural (+ Int64/Word64 on 32-bit arch)--All the built-in "small_passthrough_*" rules are used to avoid passing through-Integer/Natural. We now always inline `fromIntegral`.- -}
compiler/GHC/Core/Reduction.hs view
@@ -807,7 +807,7 @@ orig_ki_binders orig_inner_ki orig_roles orig_simplified_args where- orig_lc = emptyLiftingContext $ mkInScopeSet $ orig_fvs+ orig_lc = emptyLiftingContext $ mkInScopeSet orig_fvs go :: LiftingContext -- mapping from tyvars to rewriting coercions -> [TyCoBinder] -- Unsubsted binders of function's kind
compiler/GHC/Core/SimpleOpt.hs view
@@ -4,8 +4,6 @@ -} -{-# LANGUAGE MultiWayIf #-}- module GHC.Core.SimpleOpt ( SimpleOpts (..), defaultSimpleOpts, @@ -1284,36 +1282,15 @@ exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal -- Same deal as exprIsConApp_maybe, but much simpler -- Nevertheless we do need to look through unfoldings for--- Integer and string literals, which are vigorously hoisted to top level+-- string literals, which are vigorously hoisted to top level -- and not subsequently inlined exprIsLiteral_maybe env@(_, id_unf) e = case e of Lit l -> Just l Tick _ e' -> exprIsLiteral_maybe env e' -- dubious?- Var v- | Just rhs <- expandUnfolding_maybe (id_unf v)- , Just l <- exprIsLiteral_maybe env rhs- -> Just l- Var v- | Just rhs <- expandUnfolding_maybe (id_unf v)- , Just b <- matchBignum env rhs- -> Just b- e- | Just b <- matchBignum env e- -> Just b-- | otherwise- -> Nothing- where- matchBignum env e- | Just (_env,_fb,dc,_tys,[arg]) <- exprIsConApp_maybe env e- , Just (LitNumber _ i) <- exprIsLiteral_maybe env arg- = if- | dc == naturalNSDataCon -> Just (mkLitNatural i)- | dc == integerISDataCon -> Just (mkLitInteger i)- | otherwise -> Nothing- | otherwise- = Nothing+ Var v -> expandUnfolding_maybe (id_unf v)+ >>= exprIsLiteral_maybe env+ _ -> Nothing {- Note [exprIsLambda_maybe]
compiler/GHC/Core/TyCo/Rep.hs view
@@ -166,10 +166,10 @@ | CastTy Type KindCoercion -- ^ A kind cast. The coercion is always nominal.- -- INVARIANT: The cast is never reflexive- -- INVARIANT: The Type is not a CastTy (use TransCo instead)- -- INVARIANT: The Type is not a ForAllTy over a type variable- -- See Note [Respecting definitional equality] \(EQ2), (EQ3), (EQ4)+ -- INVARIANT: The cast is never reflexive \(EQ2)+ -- INVARIANT: The Type is not a CastTy (use TransCo instead) \(EQ3)+ -- INVARIANT: The Type is not a ForAllTy over a tyvar \(EQ4)+ -- See Note [Respecting definitional equality] | CoercionTy Coercion -- ^ Injection of a Coercion into a type@@ -302,6 +302,31 @@ In a FunTy { ft_af = InvisArg }, the argument type is always a Predicate type. +Note [Weird typing rule for ForAllTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here are the typing rules for ForAllTy:++tyvar : Type+inner : TYPE r+tyvar does not occur in r+------------------------------------+ForAllTy (Bndr tyvar vis) inner : TYPE r++inner : TYPE r+------------------------------------+ForAllTy (Bndr covar vis) inner : Type++Note that the kind of the result depends on whether the binder is a+tyvar or a covar. The kind of a forall-over-tyvar is the same as+the kind of the inner type. This is because quantification over types+is erased before runtime. By contrast, the kind of a forall-over-covar+is always Type, because a forall-over-covar is compiled into a function+taking a 0-bit-wide erased coercion argument.++Because the tyvar form above includes r in its result, we must+be careful not to let any variables escape -- thus the last premise+of the rule above.+ Note [Constraints in kinds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Do we allow a type constructor to have a kind like@@ -452,7 +477,7 @@ are interchangeable. But let's be more precise. If we examine the typing rules of FC (say, those in-https://cs.brynmawr.edu/~rae/papers/2015/equalities/equalities.pdf)+https://richarde.dev/papers/2015/equalities/equalities.pdf) there are several places where the same metavariable is used in two different premises to a rule. (For example, see Ty_App.) There is an implicit equality check here. What definition of equality should we use? By convention, we use@@ -470,7 +495,7 @@ those rules must also be admissible. A more drawn out argument around all of this is presented in Section 7.2 of-Richard E's thesis (http://cs.brynmawr.edu/~rae/papers/2016/thesis/eisenberg-thesis.pdf).+Richard E's thesis (http://richarde.dev/papers/2016/thesis/eisenberg-thesis.pdf). What would go wrong if we insisted on the casts matching? See the beginning of Section 8 in the unpublished paper above. Theoretically, nothing at all goes@@ -482,8 +507,8 @@ and we would need enormous casts with lots of CoherenceCo's to straighten them out. -Would anything go wrong if eqType respected type families? No, not at all. But-that makes eqType rather hard to implement.+Would anything go wrong if eqType looked through type families? No, not at+all. But that makes eqType rather hard to implement. Thus, the guideline for eqType is that it should be the largest easy-to-implement relation that is still smaller than ~ and homogeneous. The@@ -497,6 +522,23 @@ This principle also tells us that eqType must relate only types with the same kinds. +Interestingly, it must be the case that the free variables of t1 and t2+might be different, even if t1 `eqType` t2. A simple example of this is+if we have both cv1 :: k1 ~ k2 and cv2 :: k1 ~ k2 in the environment.+Then t1 = t |> cv1 and t2 = t |> cv2 are eqType; yet cv1 is in the free+vars of t1 and cv2 is in the free vars of t2. Unless we choose to implement+eqType to be just α-equivalence, this wrinkle around free variables+remains.++Yet not all is lost: we can say that any two equal types share the same+*relevant* free variables. Here, a relevant variable is a shallow+free variable (see Note [Shallow and deep free variables] in GHC.Core.TyCo.FVs)+that does not appear within a coercion. Note that type variables can+appear within coercions (in, say, a Refl node), but that coercion variables+cannot appear outside a coercion. We do not (yet) have a function to+extract relevant free variables, but it would not be hard to write if+the need arises.+ Besides eqType, another equality relation that upholds the (EQ) property above is /typechecker equality/, which is implemented as GHC.Tc.Utils.TcType.tcEqType. See@@ -525,7 +567,7 @@ Accordingly, by eliminating reflexive casts, splitTyConApp need not worry about outermost casts to uphold (EQ). Eliminating reflexive casts is done-in mkCastTy.+in mkCastTy. This is (EQ1) below. Unforunately, that's not the end of the story. Consider comparing (T a b c) =? (T a b |> (co -> <Type>)) (c |> co)@@ -548,6 +590,7 @@ In order to detect reflexive casts reliably, we must make sure not to have nested casts: we update (t |> co1 |> co2) to (t |> (co1 `TransCo` co2)).+This is (EQ2) below. One other troublesome case is ForAllTy. See Note [Weird typing rule for ForAllTy]. The kind of the body is the same as the kind of the ForAllTy. Accordingly,@@ -569,6 +612,25 @@ See Note [Weird typing rule for ForAllTy] These invariants are all documented above, in the declaration for Type.++Note [Equality on FunTys]+~~~~~~~~~~~~~~~~~~~~~~~~~+A (FunTy vis mult arg res) is just an abbreviation for a+ TyConApp funTyCon [mult, arg_rep, res_rep, arg, res]+where+ arg :: TYPE arg_rep+ res :: TYPE res_rep+Note that the vis field of a FunTy appears nowhere in the+equivalent TyConApp. In Core, this is OK, because we no longer+care about the visibility of the argument in a FunTy+(the vis distinguishes between arg -> res and arg => res).+In the type-checker, we are careful not to decompose FunTys+with an invisible argument. See also Note [Decomposing fat arrow c=>t]+in GHC.Core.Type.++In order to compare FunTys while respecting how they could+expand into TyConApps, we must check+the kinds of the arg and the res. Note [Unused coercion variable in ForAllTy] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Core/TyCon/Env.hs view
@@ -16,7 +16,7 @@ -- ** Manipulating these environments mkTyConEnv, mkTyConEnvWith, emptyTyConEnv, isEmptyTyConEnv,- unitTyConEnv, nameEnvElts,+ unitTyConEnv, nonDetTyConEnvElts, extendTyConEnv_C, extendTyConEnv_Acc, extendTyConEnv, extendTyConEnvList, extendTyConEnvList_C, filterTyConEnv, anyTyConEnv,@@ -56,7 +56,7 @@ isEmptyTyConEnv :: TyConEnv a -> Bool mkTyConEnv :: [(TyCon,a)] -> TyConEnv a mkTyConEnvWith :: (a -> TyCon) -> [a] -> TyConEnv a-nameEnvElts :: TyConEnv a -> [a]+nonDetTyConEnvElts :: TyConEnv a -> [a] alterTyConEnv :: (Maybe a-> Maybe a) -> TyConEnv a -> TyCon -> TyConEnv a extendTyConEnv_C :: (a->a->a) -> TyConEnv a -> TyCon -> a -> TyConEnv a extendTyConEnv_Acc :: (a->b->b) -> (a->b) -> TyConEnv b -> TyCon -> a -> TyConEnv b@@ -78,7 +78,7 @@ mapTyConEnv :: (elt1 -> elt2) -> TyConEnv elt1 -> TyConEnv elt2 disjointTyConEnv :: TyConEnv a -> TyConEnv a -> Bool -nameEnvElts x = eltsUFM x+nonDetTyConEnvElts x = nonDetEltsUFM x emptyTyConEnv = emptyUFM isEmptyTyConEnv = isNullUFM unitTyConEnv x y = unitUFM x y
compiler/GHC/Core/Type.hs view
@@ -43,6 +43,7 @@ tcSplitTyConApp_maybe, splitListTyConApp_maybe, repSplitTyConApp_maybe,+ tcRepSplitTyConApp_maybe, mkForAllTy, mkForAllTys, mkInvisForAllTys, mkTyCoInvForAllTys, mkSpecForAllTy, mkSpecForAllTys,@@ -407,6 +408,8 @@ -- Returns 'Nothing' if there is nothing to look through. -- This function considers 'Constraint' to be a synonym of @Type@. --+-- This function does not look through type family applications.+-- -- By being non-recursive and inlined, this case analysis gets efficiently -- joined onto the case analysis that the caller is already doing coreView ty@(TyConApp tc tys)@@ -1058,14 +1061,17 @@ -- ^ Does the AppTy split as in 'tcSplitAppTy_maybe', but assumes that -- any coreView stuff is already done. Refuses to look through (c => t) tcRepSplitAppTy_maybe (FunTy { ft_af = af, ft_mult = w, ft_arg = ty1, ft_res = ty2 })- | InvisArg <- af- = Nothing -- See Note [Decomposing fat arrow c=>t]- | otherwise+ | VisArg <- af -- See Note [Decomposing fat arrow c=>t]++ -- See Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType,+ -- Wrinkle around FunTy+ , Just rep1 <- getRuntimeRep_maybe ty1+ , Just rep2 <- getRuntimeRep_maybe ty2 = Just (TyConApp funTyCon [w, rep1, rep2, ty1], ty2)- where- rep1 = getRuntimeRep ty1- rep2 = getRuntimeRep ty2 + | otherwise+ = Nothing+ tcRepSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) tcRepSplitAppTy_maybe (TyConApp tc tys) | not (mustBeSaturated tc) || tys `lengthExceeds` tyConArity tc@@ -1472,30 +1478,39 @@ tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type]) -- Defined here to avoid module loops between Unify and TcType. tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty'-tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)-tcSplitTyConApp_maybe (FunTy VisArg w arg res)- | Just arg_rep <- getRuntimeRep_maybe arg- , Just res_rep <- getRuntimeRep_maybe res- = Just (funTyCon, [w, arg_rep, res_rep, arg, res])-tcSplitTyConApp_maybe _ = Nothing+ | otherwise = tcRepSplitTyConApp_maybe ty ------------------- repSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) -- ^ Like 'splitTyConApp_maybe', but doesn't look through synonyms. This -- assumes the synonyms have already been dealt with.+repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)+repSplitTyConApp_maybe (FunTy _ w arg res)+ -- NB: we're in Core, so no check for VisArg+ = Just (funTyCon, [w, arg_rep, res_rep, arg, res])+ where+ arg_rep = getRuntimeRep arg+ res_rep = getRuntimeRep res+repSplitTyConApp_maybe _ = Nothing++tcRepSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])+-- ^ Like 'tcSplitTyConApp_maybe', but doesn't look through synonyms. This+-- assumes the synonyms have already been dealt with. -- -- Moreover, for a FunTy, it only succeeds if the argument types -- have enough info to extract the runtime-rep arguments that -- the funTyCon requires. This will usually be true; -- but may be temporarily false during canonicalization: -- see Note [Decomposing FunTy] in GHC.Tc.Solver.Canonical----repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)-repSplitTyConApp_maybe (FunTy _ w arg res)+-- and Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType,+-- Wrinkle around FunTy+tcRepSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)+tcRepSplitTyConApp_maybe (FunTy VisArg w arg res)+ -- NB: VisArg. See Note [Decomposing fat arrow c=>t] | Just arg_rep <- getRuntimeRep_maybe arg , Just res_rep <- getRuntimeRep_maybe res = Just (funTyCon, [w, arg_rep, res_rep, arg, res])-repSplitTyConApp_maybe _ = Nothing+tcRepSplitTyConApp_maybe _ = Nothing ------------------- -- | Attempts to tease a list type apart and gives the type of the elements if@@ -2494,8 +2509,8 @@ -} eqType :: Type -> Type -> Bool--- ^ Type equality on source types. Does not look through @newtypes@ or--- 'PredType's, but it does look through type synonyms.+-- ^ Type equality on source types. Does not look through @newtypes@,+-- 'PredType's or type families, but it does look through type synonyms. -- This first checks that the kinds of the types are equal and then -- checks whether the types are equal, ignoring casts and coercions. -- (The kind check is a recursive call, but since all kinds have type@@ -2540,6 +2555,17 @@ comparing type variables is nondeterministic, note the call to nonDetCmpVar in nonDetCmpTypeX. See Note [Unique Determinism] for more details.++Note [Computing equality on types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are several places within GHC that depend on the precise choice of+definitional equality used. If we change that definition, all these places+must be updated. This Note merely serves as a place for all these places+to refer to, so searching for references to this Note will find every place+that needs to be updated.++See also Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep.+ -} nonDetCmpType :: Type -> Type -> Ordering@@ -2569,6 +2595,7 @@ nonDetCmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse -- See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep+ -- See Note [Computing equality on types] nonDetCmpTypeX env orig_t1 orig_t2 = case go env orig_t1 orig_t2 of -- If there are casts then we also need to do a comparison of the kinds of@@ -2623,7 +2650,10 @@ | Just (s1, t1) <- repSplitAppTy_maybe ty1 = go env s1 s2 `thenCmpTy` go env t1 t2 go env (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2)- = go env s1 s2 `thenCmpTy` go env t1 t2 `thenCmpTy` go env w1 w2+ -- NB: nonDepCmpTypeX does the kind check requested by+ -- Note [Equality on FunTys] in GHC.Core.TyCo.Rep+ = liftOrdering (nonDetCmpTypeX env s1 s2 `thenCmp` nonDetCmpTypeX env t1 t2)+ `thenCmpTy` go env w1 w2 -- Comparing multiplicities last because the test is usually true go env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = liftOrdering (tc1 `nonDetCmpTc` tc2) `thenCmpTy` gos env tys1 tys2
compiler/GHC/Core/Unfold.hs view
@@ -621,8 +621,7 @@ -- | Finds a nominal size of a string literal. litSize :: Literal -> Int -- Used by GHC.Core.Unfold.sizeExpr-litSize (LitNumber LitNumInteger _) = 100 -- Note [Size of literal integers]-litSize (LitNumber LitNumNatural _) = 100+litSize (LitNumber LitNumBigNat _) = 100 litSize (LitString str) = 10 + 10 * ((BS.length str + 3) `div` 4) -- If size could be 0 then @f "x"@ might be too small -- [Sept03: make literal strings a bit bigger to avoid fruitless
compiler/GHC/Core/Unify.hs view
@@ -800,14 +800,14 @@ Unlike the "impure unifiers" in the typechecker (the eager unifier in GHC.Tc.Utils.Unify, and the constraint solver itself in GHC.Tc.Solver.Canonical), the pure-unifier It does /not/ work up to ~.+unifier does /not/ work up to ~. The algorithm implemented here is rather delicate, and we depend on it to uphold certain properties. This is a summary of these required properties. Notation:- θ,φ substitutions+ θ,φ substitutions ξ type-function-free types τ,σ other types τ♭ type τ, flattened@@ -1067,7 +1067,7 @@ -> UM () -- See Note [Specification of unification] -- Respects newtypes, PredTypes-+-- See Note [Computing equality on types] in GHC.Core.Type unify_ty env ty1 ty2 kco -- See Note [Comparing nullary type synonyms] in GHC.Core.Type. | TyConApp tc1 [] <- ty1
compiler/GHC/Core/Utils.hs view
@@ -1944,6 +1944,8 @@ -- We don't look through loop breakers here, which is a bit conservative -- but otherwise I worry that if an Id's unfolding is just itself, -- we could get an infinite loop+ || isUnliftedType (idType v)+ -- Unlifted binders are always evaluated (#20140) is_hnf_like (Lit l) = not (isLitRubbish l) -- Regarding a LitRubbish as ConLike leads to unproductive inlining in
compiler/GHC/Driver/Flags.hs view
@@ -115,7 +115,6 @@ | Opt_D_dump_tc_trace | Opt_D_dump_ec_trace -- Pattern match exhaustiveness checker | Opt_D_dump_if_trace- | Opt_D_dump_vt_trace | Opt_D_dump_splices | Opt_D_th_dec_file | Opt_D_dump_BCOs@@ -355,6 +354,7 @@ | Opt_SuppressStgExts | Opt_SuppressTicks -- Replaces Opt_PprShowTicks | Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps+ | Opt_SuppressCoreSizes -- ^ Suppress per binding Core size stats in dumps -- temporary flags | Opt_AutoLinkPackages@@ -535,6 +535,7 @@ | Opt_WarnImplicitLift -- Since 9.2 | Opt_WarnMissingKindSignatures -- Since 9.2 | Opt_WarnMissingExportedPatternSynonymSignatures -- since 9.2+ | Opt_WarnRedundantStrictnessFlags -- Since 9.4 deriving (Eq, Show, Enum) -- | Return the names of a WarningFlag@@ -615,6 +616,7 @@ Opt_WarnUnusedRecordWildcards -> "unused-record-wildcards" :| [] Opt_WarnRedundantBangPatterns -> "redundant-bang-patterns" :| [] Opt_WarnRedundantRecordWildcards -> "redundant-record-wildcards" :| []+ Opt_WarnRedundantStrictnessFlags -> "redundant-strictness-flags" :| [] Opt_WarnWrongDoBind -> "wrong-do-bind" :| [] Opt_WarnMissingPatternSynonymSignatures -> "missing-pattern-synonym-signatures" :| [] Opt_WarnMissingDerivingStrategies -> "missing-deriving-strategies" :| []
compiler/GHC/Driver/Hooks.hs view
@@ -49,7 +49,6 @@ import GHC.Types.IPE import GHC.Types.Meta import GHC.Types.HpcInfo-import GHC.Types.ForeignStubs import GHC.Unit.Module import GHC.Unit.Module.ModSummary@@ -146,7 +145,7 @@ -> IO (Maybe HValue))) , createIservProcessHook :: !(Maybe (CreateProcess -> IO ProcessHandle)) , stgToCmmHook :: !(Maybe (DynFlags -> Module -> InfoTableProvMap -> [TyCon] -> CollectedCCs- -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup (CStub, ModuleLFInfos)))+ -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ModuleLFInfos)) , cmmToRawCmmHook :: !(forall a . Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a -> IO (Stream IO RawCmmGroup a))) }
compiler/GHC/Driver/Session.hs view
@@ -39,7 +39,7 @@ xopt_FieldSelectors, lang_set, DynamicTooState(..), dynamicTooState, setDynamicNow, setDynamicTooFailed,- dynamicOutputFile,+ dynamicOutputFile, dynamicOutputHi, sccProfilingEnabled, DynFlags(..), outputFile, hiSuf, objectSuf, ways,@@ -56,7 +56,6 @@ DynLibLoader(..), fFlags, fLangFlags, xFlags, wWarningFlags,- dynFlagDependencies, makeDynFlagsConsistent, positionIndependent, optimisationFlags,@@ -150,7 +149,7 @@ initDynFlags, -- DynFlags -> IO DynFlags defaultFatalMessager, defaultFlushOut,- setOutputFile, setDynOutputFile, setOutputHi,+ setOutputFile, setDynOutputFile, setOutputHi, setDynOutputHi, getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] getVerbFlags,@@ -540,6 +539,7 @@ outputFile_ :: Maybe String, dynOutputFile_ :: Maybe String, outputHi :: Maybe String,+ dynOutputHi :: Maybe String, dynLibLoader :: DynLibLoader, dynamicNow :: !Bool, -- ^ Indicate if we are now generating dynamic output@@ -1062,10 +1062,11 @@ -- | Compute the path of the dynamic object corresponding to an object file. dynamicOutputFile :: DynFlags -> FilePath -> FilePath-dynamicOutputFile dflags outputFile = dynOut outputFile- where- dynOut = flip addExtension (dynObjectSuf_ dflags) . dropExtension+dynamicOutputFile dflags outputFile = outputFile -<.> dynObjectSuf_ dflags +dynamicOutputHi :: DynFlags -> FilePath -> FilePath+dynamicOutputHi dflags hi = hi -<.> dynHiSuf_ dflags+ ----------------------------------------------------------------------------- -- | Used by 'GHC.runGhc' to partially initialize a new 'DynFlags' value@@ -1183,6 +1184,7 @@ outputFile_ = Nothing, dynOutputFile_ = Nothing, outputHi = Nothing,+ dynOutputHi = Nothing, dynLibLoader = SystemDependent, dumpPrefix = Nothing, dumpPrefixForce = Nothing,@@ -1437,7 +1439,6 @@ enableIfVerbose Opt_D_dump_rn_trace = False enableIfVerbose Opt_D_dump_cs_trace = False enableIfVerbose Opt_D_dump_if_trace = False- enableIfVerbose Opt_D_dump_vt_trace = False enableIfVerbose Opt_D_dump_tc = False enableIfVerbose Opt_D_dump_rn = False enableIfVerbose Opt_D_dump_rn_stats = False@@ -1572,10 +1573,6 @@ setLanguage :: Language -> DynP () setLanguage l = upd (`lang_set` Just l) --- | Some modules have dependencies on others through the DynFlags rather than textual imports-dynFlagDependencies :: DynFlags -> [ModuleName]-dynFlagDependencies = pluginModNames- -- | Is the -fpackage-trust mode on packageTrustOn :: DynFlags -> Bool packageTrustOn = gopt Opt_PackageTrust@@ -1684,7 +1681,7 @@ addCmdlineFramework, addHaddockOpts, addGhciScript, setInteractivePrint :: String -> DynFlags -> DynFlags-setOutputFile, setDynOutputFile, setOutputHi, setDumpPrefixForce+setOutputFile, setDynOutputFile, setOutputHi, setDynOutputHi, setDumpPrefixForce :: Maybe String -> DynFlags -> DynFlags setObjectDir f d = d { objectDir = Just f}@@ -1713,6 +1710,7 @@ setOutputFile f d = d { outputFile_ = f} setDynOutputFile f d = d { dynOutputFile_ = f} setOutputHi f d = d { outputHi = f}+setDynOutputHi f d = d { dynOutputHi = f} parseUnitInsts :: String -> Instantiations parseUnitInsts str = case filter ((=="").snd) (readP_to_S parse str) of@@ -2204,6 +2202,8 @@ (sepArg (setDynOutputFile . Just)) , make_ord_flag defGhcFlag "ohi" (hasArg (setOutputHi . Just ))+ , make_ord_flag defGhcFlag "dynohi"+ (hasArg (setDynOutputHi . Just )) , make_ord_flag defGhcFlag "osuf" (hasArg setObjectSuf) , make_ord_flag defGhcFlag "dynosuf" (hasArg setDynObjectSuf) , make_ord_flag defGhcFlag "hcsuf" (hasArg setHcSuf)@@ -2351,6 +2351,7 @@ setGeneralFlag Opt_SuppressTicks setGeneralFlag Opt_SuppressStgExts setGeneralFlag Opt_SuppressTypeSignatures+ setGeneralFlag Opt_SuppressCoreSizes setGeneralFlag Opt_SuppressTimestamps) ------ Debugging ----------------------------------------------------@@ -2497,8 +2498,6 @@ setDumpFlag' Opt_D_dump_cs_trace)) , make_ord_flag defGhcFlag "ddump-ec-trace" (setDumpFlag Opt_D_dump_ec_trace)- , make_ord_flag defGhcFlag "ddump-vt-trace"- (setDumpFlag Opt_D_dump_vt_trace) , make_ord_flag defGhcFlag "ddump-splices" (setDumpFlag Opt_D_dump_splices) , make_ord_flag defGhcFlag "dth-dec-file"@@ -3223,6 +3222,7 @@ warnSpec Opt_WarnUnusedRecordWildcards, warnSpec Opt_WarnRedundantBangPatterns, warnSpec Opt_WarnRedundantRecordWildcards,+ warnSpec Opt_WarnRedundantStrictnessFlags, warnSpec Opt_WarnWrongDoBind, warnSpec Opt_WarnMissingPatternSynonymSignatures, warnSpec Opt_WarnMissingDerivingStrategies,@@ -3270,7 +3270,8 @@ flagSpec "suppress-type-applications" Opt_SuppressTypeApplications, flagSpec "suppress-type-signatures" Opt_SuppressTypeSignatures, flagSpec "suppress-uniques" Opt_SuppressUniques,- flagSpec "suppress-var-kinds" Opt_SuppressVarKinds+ flagSpec "suppress-var-kinds" Opt_SuppressVarKinds,+ flagSpec "suppress-core-sizes" Opt_SuppressCoreSizes ] -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@
compiler/GHC/Hs/Dump.hs view
@@ -62,6 +62,7 @@ `extQ` annotationEpAnnImportDecl `extQ` annotationAnnParen `extQ` annotationTrailingAnn+ `extQ` annotationEpaLocation `extQ` addEpAnn `extQ` lit `extQ` litr `extQ` litt `extQ` sourceText@@ -253,6 +254,9 @@ annotationTrailingAnn :: EpAnn TrailingAnn -> SDoc annotationTrailingAnn = annotation' (text "EpAnn TrailingAnn")++ annotationEpaLocation :: EpAnn EpaLocation -> SDoc+ annotationEpaLocation = annotation' (text "EpAnn EpaLocation") annotation' :: forall a .(Data a, Typeable a) => SDoc -> EpAnn a -> SDoc
compiler/GHC/Hs/Expr.hs view
@@ -51,6 +51,7 @@ import GHC.Types.Fixity import GHC.Types.SourceText import GHC.Types.SrcLoc+import GHC.Types.Tickish (CoreTickish) import GHC.Types.Var( InvisTVBinder ) import GHC.Core.ConLike import GHC.Unit.Module (ModuleName)@@ -380,9 +381,6 @@ type instance XStatic GhcRn = NameSet type instance XStatic GhcTc = NameSet -type instance XTick (GhcPass _) = NoExtField-type instance XBinTick (GhcPass _) = NoExtField- type instance XPragE (GhcPass _) = NoExtField type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))))] = SrcSpanAnnL@@ -469,7 +467,19 @@ -- the data constructor when desugaring ConLike [InvisTVBinder] [Scaled TcType] + ---------------------------------------+ -- Haskell program coverage (Hpc) Support + | HsTick+ CoreTickish+ (LHsExpr GhcTc) -- sub-expression++ | HsBinTick+ Int -- module-local tick number for True+ Int -- module-local tick number for False+ (LHsExpr GhcTc) -- sub-expression++ {- ********************************************************************* * * Pretty-printing expressions@@ -675,18 +685,6 @@ ppr_expr (HsStatic _ e) = hsep [text "static", ppr e] -ppr_expr (HsTick _ tickish exp)- = pprTicks (ppr exp) $- ppr tickish <+> ppr_lexpr exp-ppr_expr (HsBinTick _ tickIdTrue tickIdFalse exp)- = pprTicks (ppr exp) $- hcat [text "bintick<",- ppr tickIdTrue,- text ",",- ppr tickIdFalse,- text ">(",- ppr exp, text ")"]- ppr_expr (XExpr x) = case ghcPass @p of #if __GLASGOW_HASKELL__ < 811 GhcPs -> ppr x@@ -707,6 +705,19 @@ -- Used in error messages generated by -- the pattern match overlap checker + ppr (HsTick tickish exp) =+ pprTicks (ppr exp) $+ ppr tickish <+> ppr_lexpr exp++ ppr (HsBinTick tickIdTrue tickIdFalse exp) =+ pprTicks (ppr exp) $+ hcat [text "bintick<",+ ppr tickIdTrue,+ text ",",+ ppr tickIdFalse,+ text ">(",+ ppr exp, text ")"]+ ppr_infix_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc ppr_infix_expr (HsVar _ (L _ v)) = Just (pprInfixOcc v) ppr_infix_expr (HsRecSel _ f) = Just (pprInfixOcc f)@@ -726,6 +737,8 @@ ppr_infix_expr_tc (WrapExpr (HsWrap _ e)) = ppr_infix_expr e ppr_infix_expr_tc (ExpansionExpr (HsExpanded a _)) = ppr_infix_expr a ppr_infix_expr_tc (ConLikeTc {}) = Nothing+ppr_infix_expr_tc (HsTick {}) = Nothing+ppr_infix_expr_tc (HsBinTick {}) = Nothing ppr_apps :: (OutputableBndrId p) => HsExpr (GhcPass p)@@ -809,8 +822,6 @@ go (HsTcBracketOut{}) = False go (HsProc{}) = prec > topPrec go (HsStatic{}) = prec >= appPrec- go (HsTick _ _ (L _ e)) = go e- go (HsBinTick _ _ _ (L _ e)) = go e go (RecordCon{}) = False go (HsRecSel{}) = False go (HsProjection{}) = True@@ -826,6 +837,8 @@ go_x_tc (WrapExpr (HsWrap _ e)) = hsExprNeedsParens prec e go_x_tc (ExpansionExpr (HsExpanded a _)) = hsExprNeedsParens prec a go_x_tc (ConLikeTc {}) = False+ go_x_tc (HsTick _ (L _ e)) = hsExprNeedsParens prec e+ go_x_tc (HsBinTick _ _ (L _ e)) = hsExprNeedsParens prec e go_x_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Bool go_x_rn (HsExpanded a _) = hsExprNeedsParens prec a@@ -866,6 +879,8 @@ go_x_tc (WrapExpr (HsWrap _ e)) = isAtomicHsExpr e go_x_tc (ExpansionExpr (HsExpanded a _)) = isAtomicHsExpr a go_x_tc (ConLikeTc {}) = True+ go_x_tc (HsTick {}) = False+ go_x_tc (HsBinTick {}) = False go_x_rn (HsExpanded a _) = isAtomicHsExpr a @@ -1274,7 +1289,12 @@ hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)] hsLMatchPats (L _ (Match { m_pats = pats })) = pats -type instance XCGRHSs (GhcPass _) _ = NoExtField+-- We keep the type checker happy by providing EpAnnComments. They+-- can only be used if they follow a `where` keyword with no binds,+-- but in that case the comment is attached to the following parsed+-- item. So this can never be used in practice.+type instance XCGRHSs (GhcPass _) _ = EpAnnComments+ type instance XXGRHSs (GhcPass _) _ = NoExtCon data GrhsAnn@@ -1887,9 +1907,10 @@ pprStmtInCtxt :: (OutputableBndrId idL, OutputableBndrId idR,+ OutputableBndrId ctx, Outputable body, Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA)- => HsStmtContext (GhcPass idL)+ => HsStmtContext (GhcPass ctx) -> StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc pprStmtInCtxt ctxt (LastStmt _ e _ _)
compiler/GHC/Hs/Pat.hs view
@@ -147,7 +147,7 @@ type instance XNPat GhcRn = EpAnn [AddEpAnn] type instance XNPat GhcTc = Type -type instance XNPlusKPat GhcPs = EpAnn [AddEpAnn]+type instance XNPlusKPat GhcPs = EpAnn EpaLocation -- Of the "+" type instance XNPlusKPat GhcRn = NoExtField type instance XNPlusKPat GhcTc = Type
compiler/GHC/Hs/Utils.hs view
@@ -174,7 +174,7 @@ ~ SrcSpanAnnA, Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan)- => HsMatchContext (NoGhcTc (GhcPass p))+ => HsMatchContext (GhcPass p) -> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p)) -> LMatch (GhcPass p) (LocatedA (body (GhcPass p))) mkSimpleMatch ctxt pats rhs@@ -191,7 +191,7 @@ => SrcSpan -> LocatedA (body (GhcPass p)) -> EpAnn GrhsAnn -> GRHSs (GhcPass p) (LocatedA (body (GhcPass p))) unguardedGRHSs loc rhs an- = GRHSs noExtField (unguardedRHS an loc rhs) emptyLocalBinds+ = GRHSs emptyComments (unguardedRHS an loc rhs) emptyLocalBinds unguardedRHS :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan@@ -309,7 +309,7 @@ mkNPat :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> EpAnn [AddEpAnn] -> Pat GhcPs-mkNPlusKPat :: LocatedN RdrName -> Located (HsOverLit GhcPs) -> EpAnn [AddEpAnn]+mkNPlusKPat :: LocatedN RdrName -> Located (HsOverLit GhcPs) -> EpAnn EpaLocation -> Pat GhcPs -- NB: The following functions all use noSyntaxExpr: the generated expressions@@ -913,7 +913,7 @@ ------------ mkMatch :: forall p. IsPass p- => HsMatchContext (NoGhcTc (GhcPass p))+ => HsMatchContext (GhcPass p) -> [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> HsLocalBinds (GhcPass p)@@ -922,7 +922,7 @@ = noLocA (Match { m_ext = noAnn , m_ctxt = ctxt , m_pats = map mkParPat pats- , m_grhss = GRHSs noExtField (unguardedRHS noAnn noSrcSpan expr) binds })+ , m_grhss = GRHSs emptyComments (unguardedRHS noAnn noSrcSpan expr) binds }) {- ************************************************************************
compiler/GHC/HsToCore/Errors/Ppr.hs view
@@ -304,7 +304,7 @@ DsNotYetHandledByTH{} -> noHints DsAggregatedViewExpressions{} -> noHints DsUnbangedStrictPatterns{} -> noHints- DsCannotMixPolyAndUnliftedBindings{} -> [SuggestAddTypeSignature]+ DsCannotMixPolyAndUnliftedBindings{} -> [SuggestAddTypeSignatures UnnamedBinding] DsWrongDoBind rhs _ -> [SuggestBindToWildcard rhs] DsUnusedDoBind rhs _ -> [SuggestBindToWildcard rhs] DsRecBindsNotAllowedForUnliftedTys{} -> noHints
compiler/GHC/HsToCore/Pmc/Solver/Types.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE MultiWayIf #-} -- | Domain types used in "GHC.HsToCore.Pmc.Solver". -- The ultimate goal is to define 'Nabla', which models normalised refinement@@ -49,6 +50,7 @@ import GHC.Core.ConLike import GHC.Utils.Outputable import GHC.Utils.Panic.Plain+import GHC.Utils.Misc (lastMaybe) import GHC.Data.List.SetOps (unionLists) import GHC.Data.Maybe import GHC.Core.Type@@ -620,17 +622,24 @@ | Just dc <- isDataConWorkId_maybe x , dc `elem` [intDataCon, wordDataCon, charDataCon, floatDataCon, doubleDataCon] -> literalToPmLit (exprType e) l- (Var x, [_ty, Lit n, Lit d])+ (Var x, [Lit (LitNumber _ l)])+ | Just (ty,l) <- bignum_lit_maybe x l+ -> Just (PmLit ty (PmLitInt l))+ (Var x, [_ty, n_arg, d_arg]) | Just dc <- isDataConWorkId_maybe x , dataConName dc == ratioDataConName+ , Just (PmLit _ (PmLitInt n)) <- coreExprAsPmLit n_arg+ , Just (PmLit _ (PmLitInt d)) <- coreExprAsPmLit d_arg -- HACK: just assume we have a literal double. This case only occurs for -- overloaded lits anyway, so we immediately override type information- -> literalToPmLit (exprType e) (mkLitDouble (litValue n % litValue d))+ -> literalToPmLit (exprType e) (mkLitDouble (n % d))+ (Var x, args) -- See Note [Detecting overloaded literals with -XRebindableSyntax] | is_rebound_name x fromIntegerName- , [Lit l] <- dropWhile (not . is_lit) args- -> literalToPmLit (literalType l) l >>= overloadPmLit (exprType e)+ , Just arg <- lastMaybe args+ , Just (_ty,l) <- bignum_conapp_maybe arg+ -> Just (PmLit integerTy (PmLitInt l)) >>= overloadPmLit (exprType e) (Var x, args) -- See Note [Detecting overloaded literals with -XRebindableSyntax] -- fromRational <expr>@@ -644,16 +653,16 @@ -- See Note [Dealing with rationals with large exponents] -- mkRationalBase* <rational> <exponent> | Just exp_base <- is_larg_exp_ratio x- , [r, Lit exp] <- dropWhile (not . is_ratio) args- , (Var x, [_ty, Lit n, Lit d]) <- collectArgs r+ , [r, exp] <- dropWhile (not . is_ratio) args+ , (Var x, [_ty, n_arg, d_arg]) <- collectArgs r , Just dc <- isDataConWorkId_maybe x , dataConName dc == ratioDataConName+ , Just (PmLit _ (PmLitInt n)) <- coreExprAsPmLit n_arg+ , Just (PmLit _ (PmLitInt d)) <- coreExprAsPmLit d_arg+ , Just (_exp_ty,exp') <- bignum_conapp_maybe exp -> do- n' <- isLitValue_maybe n- d' <- isLitValue_maybe d- exp' <- isLitValue_maybe exp- let rational = (abs n') :% d'- let neg = if n' < 0 then 1 else 0+ let rational = (abs n) :% d+ let neg = if n < 0 then 1 else 0 let frac = mkFractionalLit NoSourceText False rational exp' exp_base Just $ PmLit (exprType e) (PmLitOverRat neg frac) @@ -675,8 +684,20 @@ _ -> Nothing where- is_lit Lit{} = True- is_lit _ = False+ bignum_conapp_maybe (App (Var x) (Lit (LitNumber _ l)))+ = bignum_lit_maybe x l+ bignum_conapp_maybe _ = Nothing++ bignum_lit_maybe x l+ | Just dc <- isDataConWorkId_maybe x+ = if | dc == integerISDataCon -> Just (integerTy,l)+ | dc == integerIPDataCon -> Just (integerTy,l)+ | dc == integerINDataCon -> Just (integerTy,negate l)+ | dc == naturalNSDataCon -> Just (naturalTy,l)+ | dc == naturalNBDataCon -> Just (naturalTy,l)+ | otherwise -> Nothing+ bignum_lit_maybe _ _ = Nothing+ is_ratio (Type _) = False is_ratio r | Just (tc, _) <- splitTyConApp_maybe (exprType r)
compiler/GHC/Iface/Type.hs view
@@ -87,6 +87,7 @@ import GHC.Data.FastString import GHC.Utils.Misc import GHC.Utils.Panic+import {-# SOURCE #-} GHC.Tc.Utils.TcType ( isMetaTyVar, isTyConableTyVar ) import Data.Maybe( isJust ) import qualified Data.Semigroup as Semi@@ -1006,18 +1007,25 @@ This applies to /quantified/ variables like 'w' above. What about variables that are /free/ in the type being printed, which certainly-happens in error messages. Suppose (#16074) we are reporting a-mismatch between two skolems+happens in error messages. Suppose (#16074, #19361) we are reporting a+mismatch between skolems (a :: RuntimeRep) ~ (b :: RuntimeRep)-We certainly don't want to say "Can't match LiftedRep ~ LiftedRep"!+ or+ (m :: Multiplicity) ~ Many+We certainly don't want to say "Can't match LiftedRep with LiftedRep" or+"Can't match Many with Many"! But if we are printing the type- (forall (a :: TYPE r). blah+ (forall (a :: TYPE r). blah) we do want to turn that (free) r into LiftedRep, so it prints as (forall a. blah) -Conclusion: keep track of whether we are in the kind of a-binder; only if so, convert free RuntimeRep variables to LiftedRep.+We use isMetaTyVar to distinguish between those two situations:+metavariables are converted, skolem variables are not.++There's one exception though: TyVarTv metavariables should not be defaulted,+as they appear during kind-checking of "newtype T :: TYPE r where..."+(test T18357a). Therefore, we additionally test for isTyConableTyVar. -} -- | Default 'RuntimeRep' variables to 'LiftedRep', and 'Multiplicity'@@ -1039,65 +1047,68 @@ -- type signatures (e.g. ($)). See Note [Defaulting RuntimeRep variables] -- and #11549 for further discussion. defaultNonStandardVars :: Bool -> Bool -> IfaceType -> IfaceType-defaultNonStandardVars do_runtimereps do_multiplicities ty = go False emptyFsEnv ty+defaultNonStandardVars do_runtimereps do_multiplicities ty = go emptyFsEnv ty where- go :: Bool -- True <=> Inside the kind of a binder- -> FastStringEnv IfaceType -- Set of enclosing forall-ed RuntimeRep/Multiplicity variables+ go :: FastStringEnv IfaceType -- Set of enclosing forall-ed RuntimeRep/Multiplicity variables -> IfaceType -> IfaceType- go ink subs (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty)+ go subs (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty) | isInvisibleArgFlag argf -- Don't default *visible* quantification -- or we get the mess in #13963 , Just substituted_ty <- check_substitution var_kind = let subs' = extendFsEnv subs var substituted_ty -- Record that we should replace it with LiftedRep, -- and recurse, discarding the forall- in go ink subs' ty+ in go subs' ty - go ink subs (IfaceForAllTy bndr ty)- = IfaceForAllTy (go_ifacebndr subs bndr) (go ink subs ty)+ go subs (IfaceForAllTy bndr ty)+ = IfaceForAllTy (go_ifacebndr subs bndr) (go subs ty) - go _ subs ty@(IfaceTyVar tv) = case lookupFsEnv subs tv of+ go subs ty@(IfaceTyVar tv) = case lookupFsEnv subs tv of Just s -> s Nothing -> ty - go in_kind _ ty@(IfaceFreeTyVar tv)+ go _ ty@(IfaceFreeTyVar tv) -- See Note [Defaulting RuntimeRep variables], about free vars- | in_kind && do_runtimereps && GHC.Core.Type.isRuntimeRepTy (tyVarKind tv)+ | do_runtimereps && GHC.Core.Type.isRuntimeRepTy (tyVarKind tv)+ , isMetaTyVar tv+ , isTyConableTyVar tv = liftedRep_ty | do_multiplicities && GHC.Core.Type.isMultiplicityTy (tyVarKind tv)+ , isMetaTyVar tv+ , isTyConableTyVar tv = many_ty | otherwise = ty - go ink subs (IfaceTyConApp tc tc_args)- = IfaceTyConApp tc (go_args ink subs tc_args)+ go subs (IfaceTyConApp tc tc_args)+ = IfaceTyConApp tc (go_args subs tc_args) - go ink subs (IfaceTupleTy sort is_prom tc_args)- = IfaceTupleTy sort is_prom (go_args ink subs tc_args)+ go subs (IfaceTupleTy sort is_prom tc_args)+ = IfaceTupleTy sort is_prom (go_args subs tc_args) - go ink subs (IfaceFunTy af w arg res)- = IfaceFunTy af (go ink subs w) (go ink subs arg) (go ink subs res)+ go subs (IfaceFunTy af w arg res)+ = IfaceFunTy af (go subs w) (go subs arg) (go subs res) - go ink subs (IfaceAppTy t ts)- = IfaceAppTy (go ink subs t) (go_args ink subs ts)+ go subs (IfaceAppTy t ts)+ = IfaceAppTy (go subs t) (go_args subs ts) - go ink subs (IfaceCastTy x co)- = IfaceCastTy (go ink subs x) co+ go subs (IfaceCastTy x co)+ = IfaceCastTy (go subs x) co - go _ _ ty@(IfaceLitTy {}) = ty- go _ _ ty@(IfaceCoercionTy {}) = ty+ go _ ty@(IfaceLitTy {}) = ty+ go _ ty@(IfaceCoercionTy {}) = ty go_ifacebndr :: FastStringEnv IfaceType -> IfaceForAllBndr -> IfaceForAllBndr go_ifacebndr subs (Bndr (IfaceIdBndr (w, n, t)) argf)- = Bndr (IfaceIdBndr (w, n, go True subs t)) argf+ = Bndr (IfaceIdBndr (w, n, go subs t)) argf go_ifacebndr subs (Bndr (IfaceTvBndr (n, t)) argf)- = Bndr (IfaceTvBndr (n, go True subs t)) argf+ = Bndr (IfaceTvBndr (n, go subs t)) argf - go_args :: Bool -> FastStringEnv IfaceType -> IfaceAppArgs -> IfaceAppArgs- go_args _ _ IA_Nil = IA_Nil- go_args ink subs (IA_Arg ty argf args)- = IA_Arg (go ink subs ty) argf (go_args ink subs args)+ go_args :: FastStringEnv IfaceType -> IfaceAppArgs -> IfaceAppArgs+ go_args _ IA_Nil = IA_Nil+ go_args subs (IA_Arg ty argf args)+ = IA_Arg (go subs ty) argf (go_args subs args) check_substitution :: IfaceType -> Maybe IfaceType check_substitution (IfaceTyConApp tc _)
compiler/GHC/Parser/Annotation.hs view
@@ -13,7 +13,7 @@ -- * In-tree Exact Print Annotations AddEpAnn(..),- EpaLocation(..), epaLocationRealSrcSpan,+ EpaLocation(..), epaLocationRealSrcSpan, epaLocationFromSrcAnn, DeltaPos(..), deltaPos, getDeltaLine, EpAnn(..), Anchor(..), AnchorOperation(..),@@ -439,6 +439,10 @@ epaLocationRealSrcSpan :: EpaLocation -> RealSrcSpan epaLocationRealSrcSpan (EpaSpan r) = r epaLocationRealSrcSpan (EpaDelta _) = panic "epaLocationRealSrcSpan"++epaLocationFromSrcAnn :: SrcAnn ann -> EpaLocation+epaLocationFromSrcAnn (SrcSpanAnn EpAnnNotUsed l) = EpaSpan (realSrcSpan l)+epaLocationFromSrcAnn (SrcSpanAnn (EpAnn anc _ _) _) = EpaSpan (anchor anc) instance Outputable EpaLocation where ppr (EpaSpan r) = text "EpaSpan" <+> ppr r
compiler/GHC/Parser/Errors/Ppr.hs view
@@ -469,6 +469,7 @@ [ text "Parse error" <> colon <+> quotes (ppr arr) , text "Record constructors in GADTs must use an ordinary, non-linear arrow." ]+ PsErrInvalidCApiImport {} -> mkSimpleDecorated $ vcat [ text "Wrapper stubs can't be used with CApiFFI."] diagnosticReason = \case PsUnknownMessage m -> diagnosticReason m@@ -580,6 +581,7 @@ PsErrInvalidPackageName{} -> ErrorWithoutFlag PsErrParseRightOpSectionInPat{} -> ErrorWithoutFlag PsErrIllegalGadtRecordMultiplicity{} -> ErrorWithoutFlag+ PsErrInvalidCApiImport {} -> ErrorWithoutFlag diagnosticHints = \case PsUnknownMessage m -> diagnosticHints m@@ -737,6 +739,7 @@ PsErrUnexpectedTypeInDecl{} -> noHints PsErrInvalidPackageName{} -> noHints PsErrIllegalGadtRecordMultiplicity{} -> noHints+ PsErrInvalidCApiImport {} -> noHints psHeaderMessageDiagnostic :: PsHeaderMessage -> DecoratedSDoc psHeaderMessageDiagnostic = \case
compiler/GHC/Parser/Errors/Types.hs view
@@ -440,6 +440,8 @@ -- | Illegal linear arrow or multiplicity annotation in GADT record syntax | PsErrIllegalGadtRecordMultiplicity !(HsArrow GhcPs) + | PsErrInvalidCApiImport+ newtype StarIsType = StarIsType Bool -- | Extra details about a parse error, which helps
compiler/GHC/Parser/PostProcess.hs view
@@ -437,21 +437,23 @@ PsErrInferredTypeVarNotAllowed -- | Add the annotation for a 'where' keyword to existing @HsLocalBinds@-annBinds :: AddEpAnn -> HsLocalBinds GhcPs -> HsLocalBinds GhcPs-annBinds a (HsValBinds an bs) = (HsValBinds (add_where a an) bs)-annBinds a (HsIPBinds an bs) = (HsIPBinds (add_where a an) bs)-annBinds _ (EmptyLocalBinds x) = (EmptyLocalBinds x)+annBinds :: AddEpAnn -> EpAnnComments -> HsLocalBinds GhcPs+ -> (HsLocalBinds GhcPs, Maybe EpAnnComments)+annBinds a cs (HsValBinds an bs) = (HsValBinds (add_where a an cs) bs, Nothing)+annBinds a cs (HsIPBinds an bs) = (HsIPBinds (add_where a an cs) bs, Nothing)+annBinds _ cs (EmptyLocalBinds x) = (EmptyLocalBinds x, Just cs) -add_where :: AddEpAnn -> EpAnn AnnList -> EpAnn AnnList-add_where an@(AddEpAnn _ (EpaSpan rs)) (EpAnn a (AnnList anc o c r t) cs)+add_where :: AddEpAnn -> EpAnn AnnList -> EpAnnComments -> EpAnn AnnList+add_where an@(AddEpAnn _ (EpaSpan rs)) (EpAnn a (AnnList anc o c r t) cs) cs2 | valid_anchor (anchor a)- = EpAnn (widenAnchor a [an]) (AnnList anc o c (an:r) t) cs+ = EpAnn (widenAnchor a [an]) (AnnList anc o c (an:r) t) (cs Semi.<> cs2) | otherwise- = EpAnn (patch_anchor rs a) (AnnList (fmap (patch_anchor rs) anc) o c (an:r) t) cs-add_where an@(AddEpAnn _ (EpaSpan rs)) EpAnnNotUsed+ = EpAnn (patch_anchor rs a)+ (AnnList (fmap (patch_anchor rs) anc) o c (an:r) t) (cs Semi.<> cs2)+add_where an@(AddEpAnn _ (EpaSpan rs)) EpAnnNotUsed cs = EpAnn (Anchor rs UnchangedAnchor)- (AnnList (Just $ Anchor rs UnchangedAnchor) Nothing Nothing [an] []) emptyComments-add_where (AddEpAnn _ (EpaDelta _)) _ = panic "add_where"+ (AnnList (Just $ Anchor rs UnchangedAnchor) Nothing Nothing [an] []) cs+add_where (AddEpAnn _ (EpaDelta _)) _ _ = panic "add_where" -- EpaDelta should only be used for transformations valid_anchor :: RealSrcSpan -> Bool@@ -1146,11 +1148,12 @@ -- n+k patterns PatBuilderOpApp (L _ (PatBuilderVar (L nloc n)))- (L _ plus)+ (L l plus) (L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}})))- anns+ (EpAnn anc _ cs) | nPlusKPatterns && (plus == plus_RDR)- -> return (mkNPlusKPat (L nloc n) (L (locA lloc) lit) anns)+ -> return (mkNPlusKPat (L nloc n) (L (locA lloc) lit)+ (EpAnn anc (epaLocationFromSrcAnn l) cs)) -- Improve error messages for the @-operator when the user meant an @-pattern PatBuilderOpApp _ op _ _ | opIsAt (unLoc op) -> do@@ -2528,9 +2531,13 @@ -> P (EpAnn [AddEpAnn] -> HsDecl GhcPs) mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) = case unLoc cconv of- CCallConv -> mkCImport- CApiConv -> mkCImport- StdCallConv -> mkCImport+ CCallConv -> returnSpec =<< mkCImport+ CApiConv -> do+ imp <- mkCImport+ if isCWrapperImport imp+ then addFatalError $ mkPlainErrorMsgEnvelope loc PsErrInvalidCApiImport+ else returnSpec imp+ StdCallConv -> returnSpec =<< mkCImport PrimCallConv -> mkOtherImport JavaScriptCallConv -> mkOtherImport where@@ -2543,7 +2550,10 @@ case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of Nothing -> addFatalError $ mkPlainErrorMsgEnvelope loc $ PsErrMalformedEntityString- Just importSpec -> returnSpec importSpec+ Just importSpec -> return importSpec++ isCWrapperImport (CImport _ _ _ CWrapper _) = True+ isCWrapperImport _ = False -- currently, all the other import conventions only support a symbol name in -- the entity string. If it is missing, we use the function name instead.
compiler/GHC/Platform.hs view
@@ -74,6 +74,11 @@ -- ^ Determines whether we will be compiling info tables that reside just -- before the entry code, or with an indirection to the entry code. See -- TABLES_NEXT_TO_CODE in rts/include/rts/storage/InfoTables.h.+ , platformHasLibm :: !Bool+ -- ^ Some platforms require that we explicitly link against @libm@ if any+ -- math-y things are used (which we assume to include all programs). See+ -- #14022.+ , platform_constants :: !(Maybe PlatformConstants) -- ^ Constants such as structure offsets, type sizes, etc. }@@ -93,6 +98,7 @@ , platformHasGnuNonexecStack = False , platformHasIdentDirective = False , platformHasSubsectionsViaSymbols= False+ , platformHasLibm = False , platformIsCrossCompiling = False , platformLeadingUnderscore = False , platformTablesNextToCode = True
compiler/GHC/Platform/Reg.hs view
@@ -34,7 +34,6 @@ import GHC.Types.Unique import GHC.Builtin.Uniques import GHC.Platform.Reg.Class-import Data.List (intersect) -- | An identifier for a primitive real machine register. type RegNo@@ -173,8 +172,17 @@ realRegsAlias :: RealReg -> RealReg -> Bool-realRegsAlias rr1 rr2- = not $ null $ intersect (regNosOfRealReg rr1) (regNosOfRealReg rr2)+realRegsAlias rr1 rr2 =+ -- used to be `not $ null $ intersect (regNosOfRealReg rr1) (regNosOfRealReg rr2)`+ -- but that resulted in some gnarly, gnarly, allocating code. So we manually+ -- write out all the cases which gives us nice non-allocating code.+ case rr1 of+ RealRegSingle r1 ->+ case rr2 of RealRegPair r2 r3 -> r1 == r2 || r1 == r3+ RealRegSingle r2 -> r1 == r2+ RealRegPair r1 r2 ->+ case rr2 of RealRegPair r3 r4 -> r1 == r3 || r1 == r4 || r2 == r3 || r2 == r4+ RealRegSingle r3 -> r1 == r3 || r2 == r3 -------------------------------------------------------------------------------- -- | A register, either virtual or real
compiler/GHC/Runtime/Heap/Layout.hs view
@@ -174,6 +174,7 @@ | RTSRep -- The RTS needs to declare info tables with specific Int -- type tags, so this form lets us override the default SMRep -- tag for an SMRep.+ deriving Eq -- | True \<=> This is a static closure. Affects how we garbage-collect it. -- Static closure have an extra static link field at the end.@@ -191,6 +192,7 @@ | ThunkSelector SelectorOffset | BlackHole | IndStatic+ deriving Eq type ConstrDescription = ByteString -- result of dataConIdentity type FunArity = Int@@ -444,6 +446,8 @@ HeapRep True _ _ Thunk -> THUNK_STATIC HeapRep False _ _ BlackHole -> BLACKHOLE HeapRep False _ _ IndStatic -> IND_STATIC++ StackRep _ -> STACK _ -> panic "rtsClosureType"
compiler/GHC/Tc/Errors/Ppr.hs view
@@ -9,19 +9,30 @@ import GHC.Prelude -import GHC.Core.TyCo.Ppr (pprWithTYPE)+import GHC.Core.Class (Class(..))+import GHC.Core.Coercion (pprCoAxBranchUser)+import GHC.Core.Coercion.Axiom (coAxiomTyCon, coAxiomSingleBranch)+import GHC.Core.FamInstEnv (famInstAxiom)+import GHC.Core.InstEnv+import GHC.Core.TyCo.Ppr (pprKind, pprParendType, pprType, pprWithTYPE, pprWithExplicitKindsWhen) import GHC.Core.Type import GHC.Data.Bag import GHC.Tc.Errors.Types+import GHC.Tc.Types.Rank (Rank(..))+import GHC.Tc.Utils.TcType (tcSplitForAllTyVars) import GHC.Types.Error-import GHC.Types.Name (pprPrefixName)-import GHC.Types.Name.Reader (pprNameProvenance)+import GHC.Types.FieldLabel (flIsOverloaded, flSelector)+import GHC.Types.Id (isRecordSelector)+import GHC.Types.Name+import GHC.Types.Name.Reader (GreName(..), pprNameProvenance) import GHC.Types.SrcLoc (GenLocated(..))-import GHC.Types.Name.Occurrence (occName)+import GHC.Types.TyThing import GHC.Types.Var.Env (emptyTidyEnv)+import GHC.Types.Var.Set (pprVarSet, pluralVarSet) import GHC.Driver.Flags import GHC.Hs import GHC.Utils.Outputable+import GHC.Utils.Misc (capitalise) import GHC.Unit.State (pprWithUnitState, UnitState) import qualified GHC.LanguageExtensions as LangExt import qualified Data.List.NonEmpty as NE@@ -76,11 +87,13 @@ -> mkSimpleDecorated $ vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name), text "also at " <+> ppr (getLocA d)]- TcRnSimplifierTooManyIterations limit wc+ TcRnSimplifierTooManyIterations simples limit wc -> mkSimpleDecorated $ hang (text "solveWanteds: too many iterations" <+> parens (text "limit =" <+> ppr limit))- 2 (text "Unsolved:" <+> ppr wc)+ 2 (vcat [ text "Unsolved:" <+> ppr wc+ , text "Simples:" <+> ppr simples+ ]) TcRnIllegalPatSynDecl rdrname -> mkSimpleDecorated $ hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname))@@ -169,7 +182,223 @@ -> mkSimpleDecorated $ hang (text "Overloaded signature conflicts with monomorphism restriction") 2 (ppr sig)+ TcRnTupleConstraintInst _+ -> mkSimpleDecorated $ text "You can't specify an instance for a tuple constraint"+ TcRnAbstractClassInst clas+ -> mkSimpleDecorated $+ text "Cannot define instance for abstract class" <+>+ quotes (ppr (className clas))+ TcRnNoClassInstHead tau+ -> mkSimpleDecorated $+ hang (text "Instance head is not headed by a class:") 2 (pprType tau)+ TcRnUserTypeError ty+ -> mkSimpleDecorated (pprUserTypeErrorTy ty)+ TcRnConstraintInKind ty+ -> mkSimpleDecorated $+ text "Illegal constraint in a kind:" <+> pprType ty+ TcRnUnboxedTupleTypeFuncArg ty+ -> mkSimpleDecorated $+ sep [ text "Illegal unboxed tuple type as function argument:"+ , pprType ty ]+ TcRnLinearFuncInKind ty+ -> mkSimpleDecorated $+ text "Illegal linear function in a kind:" <+> pprType ty+ TcRnForAllEscapeError ty kind+ -> mkSimpleDecorated $ vcat+ [ hang (text "Quantified type's kind mentions quantified type variable")+ 2 (text "type:" <+> quotes (ppr ty))+ , hang (text "where the body of the forall has this kind:")+ 2 (quotes (pprKind kind)) ]+ TcRnVDQInTermType ty+ -> mkSimpleDecorated $ vcat+ [ hang (text "Illegal visible, dependent quantification" <+>+ text "in the type of a term:")+ 2 (pprType ty)+ , text "(GHC does not yet support this)" ]+ TcRnIllegalEqualConstraints ty+ -> mkSimpleDecorated $+ text "Illegal equational constraint" <+> pprType ty+ TcRnBadQuantPredHead ty+ -> mkSimpleDecorated $+ hang (text "Quantified predicate must have a class or type variable head:")+ 2 (pprType ty)+ TcRnIllegalTupleConstraint ty+ -> mkSimpleDecorated $+ text "Illegal tuple constraint:" <+> pprType ty+ TcRnNonTypeVarArgInConstraint ty+ -> mkSimpleDecorated $+ hang (text "Non type-variable argument")+ 2 (text "in the constraint:" <+> pprType ty)+ TcRnIllegalImplicitParam ty+ -> mkSimpleDecorated $+ text "Illegal implicit parameter" <+> quotes (pprType ty)+ TcRnIllegalConstraintSynonymOfKind kind+ -> mkSimpleDecorated $+ text "Illegal constraint synonym of kind:" <+> quotes (pprKind kind)+ TcRnIllegalClassInst tcf+ -> mkSimpleDecorated $+ vcat [ text "Illegal instance for a" <+> ppr tcf+ , text "A class instance must be for a class" ]+ TcRnOversaturatedVisibleKindArg ty+ -> mkSimpleDecorated $+ text "Illegal oversaturated visible kind argument:" <+>+ quotes (char '@' <> pprParendType ty)+ TcRnBadAssociatedType clas tc+ -> mkSimpleDecorated $+ hsep [ text "Class", quotes (ppr clas)+ , text "does not have an associated type", quotes (ppr tc) ]+ TcRnForAllRankErr rank ty+ -> let herald = case tcSplitForAllTyVars ty of+ ([], _) -> text "Illegal qualified type:"+ _ -> text "Illegal polymorphic type:"+ extra = case rank of+ MonoTypeConstraint -> text "A constraint must be a monotype"+ _ -> empty+ in mkSimpleDecorated $ vcat [hang herald 2 (pprType ty), extra]+ TcRnMonomorphicBindings bindings+ -> let pp_bndrs = pprBindings bindings+ in mkSimpleDecorated $+ sep [ text "The Monomorphism Restriction applies to the binding"+ <> plural bindings+ , text "for" <+> pp_bndrs ]+ TcRnOrphanInstance inst+ -> mkSimpleDecorated $+ hsep [ text "Orphan instance:"+ , pprInstanceHdr inst+ ]+ TcRnFunDepConflict unit_state sorted+ -> let herald = text "Functional dependencies conflict between instance declarations:"+ in mkSimpleDecorated $+ pprWithUnitState unit_state $ (hang herald 2 (pprInstances $ NE.toList sorted))+ TcRnDupInstanceDecls unit_state sorted+ -> let herald = text "Duplicate instance declarations:"+ in mkSimpleDecorated $+ pprWithUnitState unit_state $ (hang herald 2 (pprInstances $ NE.toList sorted))+ TcRnConflictingFamInstDecls sortedNE+ -> let sorted = NE.toList sortedNE+ in mkSimpleDecorated $+ hang (text "Conflicting family instance declarations:")+ 2 (vcat [ pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax)+ | fi <- sorted+ , let ax = famInstAxiom fi ])+ TcRnFamInstNotInjective rea fam_tc (eqn1 NE.:| rest_eqns)+ -> let (herald, show_kinds) = case rea of+ InjErrRhsBareTyVar tys ->+ (injectivityErrorHerald $$+ text "RHS of injective type family equation is a bare" <+>+ text "type variable" $$+ text "but these LHS type and kind patterns are not bare" <+>+ text "variables:" <+> pprQuotedList tys, False)+ InjErrRhsCannotBeATypeFam ->+ (injectivityErrorHerald $$+ text "RHS of injective type family equation cannot" <+>+ text "be a type family:", False)+ InjErrRhsOverlap ->+ (text "Type family equation right-hand sides overlap; this violates" $$+ text "the family's injectivity annotation:", False)+ InjErrCannotInferFromRhs tvs has_kinds _ ->+ let show_kinds = has_kinds == YesHasKinds+ what = if show_kinds then text "Type/kind" else text "Type"+ body = sep [ what <+> text "variable" <>+ pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . scopedSort)+ , text "cannot be inferred from the right-hand side." ]+ in (injectivityErrorHerald $$ body $$ text "In the type family equation:", show_kinds) + in mkSimpleDecorated $ pprWithExplicitKindsWhen show_kinds $+ hang herald+ 2 (vcat (map (pprCoAxBranchUser fam_tc) (eqn1 : rest_eqns)))+ TcRnBangOnUnliftedType ty+ -> mkSimpleDecorated $+ text "Strictness flag has no effect on unlifted type" <+> quotes (ppr ty)+ TcRnMultipleDefaultDeclarations dup_things+ -> mkSimpleDecorated $+ hang (text "Multiple default declarations")+ 2 (vcat (map pp dup_things))+ where+ pp :: LDefaultDecl GhcRn -> SDoc+ pp (L locn (DefaultDecl _ _))+ = text "here was another default declaration" <+> ppr (locA locn)+ TcRnBadDefaultType ty deflt_clss+ -> mkSimpleDecorated $+ hang (text "The default type" <+> quotes (ppr ty) <+> text "is not an instance of")+ 2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss))+ TcRnPatSynBundledWithNonDataCon+ -> mkSimpleDecorated $+ text "Pattern synonyms can be bundled only with datatypes."+ TcRnPatSynBundledWithWrongType expected_res_ty res_ty+ -> mkSimpleDecorated $+ text "Pattern synonyms can only be bundled with matching type constructors"+ $$ text "Couldn't match expected type of"+ <+> quotes (ppr expected_res_ty)+ <+> text "with actual type of"+ <+> quotes (ppr res_ty)+ TcRnDupeModuleExport mod+ -> mkSimpleDecorated $+ hsep [ text "Duplicate"+ , quotes (text "Module" <+> ppr mod)+ , text "in export list" ]+ TcRnExportedModNotImported mod+ -> mkSimpleDecorated+ $ formatExportItemError+ (text "module" <+> ppr mod)+ "is not imported"+ TcRnNullExportedModule mod+ -> mkSimpleDecorated+ $ formatExportItemError+ (text "module" <+> ppr mod)+ "exports nothing"+ TcRnMissingExportList mod+ -> mkSimpleDecorated+ $ formatExportItemError+ (text "module" <+> ppr mod)+ "is missing an export list"+ TcRnExportHiddenComponents export_item+ -> mkSimpleDecorated+ $ formatExportItemError+ (ppr export_item)+ "attempts to export constructors or class methods that are not visible here"+ TcRnDuplicateExport child ie1 ie2+ -> mkSimpleDecorated $+ hsep [ quotes (ppr child)+ , text "is exported by", quotes (ppr ie1)+ , text "and", quotes (ppr ie2) ]+ TcRnExportedParentChildMismatch parent_name ty_thing child parent_names+ -> mkSimpleDecorated $+ text "The type constructor" <+> quotes (ppr parent_name)+ <+> text "is not the parent of the" <+> text what_is+ <+> quotes thing <> char '.'+ $$ text (capitalise what_is)+ <> text "s can only be exported with their parent type constructor."+ $$ (case parents of+ [] -> empty+ [_] -> text "Parent:"+ _ -> text "Parents:") <+> fsep (punctuate comma parents)+ where+ pp_category :: TyThing -> String+ pp_category (AnId i)+ | isRecordSelector i = "record selector"+ pp_category i = tyThingCategory i+ what_is = pp_category ty_thing+ thing = ppr child+ parents = map ppr parent_names+ TcRnConflictingExports occ child1 gre1 ie1 child2 gre2 ie2+ -> mkSimpleDecorated $+ vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon+ , ppr_export child1 gre1 ie1+ , ppr_export child2 gre2 ie2+ ]+ where+ ppr_export child gre ie = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+>+ quotes (ppr_name child))+ 2 (pprNameProvenance gre))++ -- DuplicateRecordFields means that nameOccName might be a mangled+ -- $sel-prefixed thing, in which case show the correct OccName alone+ -- (but otherwise show the Name so it will have a module qualifier)+ ppr_name (FieldGreName fl) | flIsOverloaded fl = ppr fl+ | otherwise = ppr (flSelector fl)+ ppr_name (NormalGreName name) = ppr name+ diagnosticReason = \case TcRnUnknownMessage m -> diagnosticReason m@@ -248,6 +477,82 @@ -> WarningWithFlag Opt_WarnMissingLocalSignatures TcRnOverloadedSig{} -> ErrorWithoutFlag+ TcRnTupleConstraintInst{}+ -> ErrorWithoutFlag+ TcRnAbstractClassInst{}+ -> ErrorWithoutFlag+ TcRnNoClassInstHead{}+ -> ErrorWithoutFlag+ TcRnUserTypeError{}+ -> ErrorWithoutFlag+ TcRnConstraintInKind{}+ -> ErrorWithoutFlag+ TcRnUnboxedTupleTypeFuncArg{}+ -> ErrorWithoutFlag+ TcRnLinearFuncInKind{}+ -> ErrorWithoutFlag+ TcRnForAllEscapeError{}+ -> ErrorWithoutFlag+ TcRnVDQInTermType{}+ -> ErrorWithoutFlag+ TcRnIllegalEqualConstraints{}+ -> ErrorWithoutFlag+ TcRnBadQuantPredHead{}+ -> ErrorWithoutFlag+ TcRnIllegalTupleConstraint{}+ -> ErrorWithoutFlag+ TcRnNonTypeVarArgInConstraint{}+ -> ErrorWithoutFlag+ TcRnIllegalImplicitParam{}+ -> ErrorWithoutFlag+ TcRnIllegalConstraintSynonymOfKind{}+ -> ErrorWithoutFlag+ TcRnIllegalClassInst{}+ -> ErrorWithoutFlag+ TcRnOversaturatedVisibleKindArg{}+ -> ErrorWithoutFlag+ TcRnBadAssociatedType{}+ -> ErrorWithoutFlag+ TcRnForAllRankErr{}+ -> ErrorWithoutFlag+ TcRnMonomorphicBindings{}+ -> WarningWithFlag Opt_WarnMonomorphism+ TcRnOrphanInstance{}+ -> WarningWithFlag Opt_WarnOrphans+ TcRnFunDepConflict{}+ -> ErrorWithoutFlag+ TcRnDupInstanceDecls{}+ -> ErrorWithoutFlag+ TcRnConflictingFamInstDecls{}+ -> ErrorWithoutFlag+ TcRnFamInstNotInjective{}+ -> ErrorWithoutFlag+ TcRnBangOnUnliftedType{}+ -> WarningWithFlag Opt_WarnRedundantStrictnessFlags+ TcRnMultipleDefaultDeclarations{}+ -> ErrorWithoutFlag+ TcRnBadDefaultType{}+ -> ErrorWithoutFlag+ TcRnPatSynBundledWithNonDataCon{}+ -> ErrorWithoutFlag+ TcRnPatSynBundledWithWrongType{}+ -> ErrorWithoutFlag+ TcRnDupeModuleExport{}+ -> WarningWithFlag Opt_WarnDuplicateExports+ TcRnExportedModNotImported{}+ -> ErrorWithoutFlag+ TcRnNullExportedModule{}+ -> WarningWithFlag Opt_WarnDodgyExports+ TcRnMissingExportList{}+ -> WarningWithFlag Opt_WarnMissingExportList+ TcRnExportHiddenComponents{}+ -> ErrorWithoutFlag+ TcRnDuplicateExport{}+ -> WarningWithFlag Opt_WarnDuplicateExports+ TcRnExportedParentChildMismatch{}+ -> ErrorWithoutFlag+ TcRnConflictingExports{}+ -> ErrorWithoutFlag diagnosticHints = \case TcRnUnknownMessage m@@ -327,6 +632,98 @@ -> noHints TcRnOverloadedSig{} -> noHints+ TcRnTupleConstraintInst{}+ -> noHints+ TcRnAbstractClassInst{}+ -> noHints+ TcRnNoClassInstHead{}+ -> noHints+ TcRnUserTypeError{}+ -> noHints+ TcRnConstraintInKind{}+ -> noHints+ TcRnUnboxedTupleTypeFuncArg{}+ -> [suggestExtension LangExt.UnboxedTuples]+ TcRnLinearFuncInKind{}+ -> noHints+ TcRnForAllEscapeError{}+ -> noHints+ TcRnVDQInTermType{}+ -> noHints+ TcRnIllegalEqualConstraints{}+ -> [suggestAnyExtension [LangExt.GADTs, LangExt.TypeFamilies]]+ TcRnBadQuantPredHead{}+ -> noHints+ TcRnIllegalTupleConstraint{}+ -> [suggestExtension LangExt.ConstraintKinds]+ TcRnNonTypeVarArgInConstraint{}+ -> [suggestExtension LangExt.FlexibleContexts]+ TcRnIllegalImplicitParam{}+ -> noHints+ TcRnIllegalConstraintSynonymOfKind{}+ -> [suggestExtension LangExt.ConstraintKinds]+ TcRnIllegalClassInst{}+ -> noHints+ TcRnOversaturatedVisibleKindArg{}+ -> noHints+ TcRnBadAssociatedType{}+ -> noHints+ TcRnForAllRankErr rank _+ -> case rank of+ LimitedRank{} -> [suggestExtension LangExt.RankNTypes]+ MonoTypeRankZero -> [suggestExtension LangExt.RankNTypes]+ MonoTypeTyConArg -> [suggestExtension LangExt.ImpredicativeTypes]+ MonoTypeSynArg -> [suggestExtension LangExt.LiberalTypeSynonyms]+ MonoTypeConstraint -> [suggestExtension LangExt.QuantifiedConstraints]+ _ -> noHints+ TcRnMonomorphicBindings bindings+ -> case bindings of+ [] -> noHints+ (x:xs) -> [SuggestAddTypeSignatures $ NamedBindings (x NE.:| xs)]+ TcRnOrphanInstance{}+ -> [SuggestFixOrphanInstance]+ TcRnFunDepConflict{}+ -> noHints+ TcRnDupInstanceDecls{}+ -> noHints+ TcRnConflictingFamInstDecls{}+ -> noHints+ TcRnFamInstNotInjective rea _ _+ -> case rea of+ InjErrRhsBareTyVar{} -> noHints+ InjErrRhsCannotBeATypeFam -> noHints+ InjErrRhsOverlap -> noHints+ InjErrCannotInferFromRhs _ _ suggestUndInst+ | YesSuggestUndecidableInstaces <- suggestUndInst+ -> [suggestExtension LangExt.UndecidableInstances]+ | otherwise+ -> noHints+ TcRnBangOnUnliftedType{}+ -> noHints+ TcRnMultipleDefaultDeclarations{}+ -> noHints+ TcRnBadDefaultType{}+ -> noHints+ TcRnPatSynBundledWithNonDataCon{}+ -> noHints+ TcRnPatSynBundledWithWrongType{}+ -> noHints+ TcRnDupeModuleExport{}+ -> noHints+ TcRnExportedModNotImported{}+ -> noHints+ TcRnNullExportedModule{}+ -> noHints+ TcRnMissingExportList{}+ -> noHints+ TcRnExportHiddenComponents{}+ -> noHints+ TcRnDuplicateExport{}+ -> noHints+ TcRnExportedParentChildMismatch{}+ -> noHints+ TcRnConflictingExports{}+ -> noHints messageWithInfoDiagnosticMessage :: UnitState -> ErrInfo@@ -398,3 +795,16 @@ RecordFieldConstructor{} -> text "construction" RecordFieldPattern{} -> text "pattern" RecordFieldUpdate -> text "update"++pprBindings :: [Name] -> SDoc+pprBindings = pprWithCommas (quotes . ppr)++injectivityErrorHerald :: SDoc+injectivityErrorHerald =+ text "Type family equation violates the family's injectivity annotation."++formatExportItemError :: SDoc -> String -> SDoc+formatExportItemError exportedThing reason =+ hsep [ text "The export item"+ , quotes exportedThing+ , text reason ]
compiler/GHC/Tc/Errors/Types.hs view
@@ -7,6 +7,11 @@ , LevityCheckProvenance(..) , ShadowedNameProvenance(..) , RecordFieldPart(..)+ , InjectivityErrReason(..)+ , HasKinds(..)+ , hasKinds+ , SuggestUndecidableInstances(..)+ , suggestUndecidableInstances ) where import GHC.Prelude@@ -14,18 +19,27 @@ import GHC.Hs import {-# SOURCE #-} GHC.Tc.Types (TcIdSigInfo) import GHC.Tc.Types.Constraint+import GHC.Tc.Types.Rank (Rank) import GHC.Types.Error import GHC.Types.Name (Name, OccName) import GHC.Types.Name.Reader import GHC.Types.SrcLoc+import GHC.Types.TyThing (TyThing) import GHC.Unit.Types (Module) import GHC.Utils.Outputable-import GHC.Core.Type (Type, Var)+import GHC.Core.Class (Class)+import GHC.Core.Coercion.Axiom (CoAxBranch)+import GHC.Core.FamInstEnv (FamInst)+import GHC.Core.InstEnv (ClsInst)+import GHC.Core.TyCon (TyCon, TyConFlavour)+import GHC.Core.Type (Kind, Type, Var) import GHC.Unit.State (UnitState)+import GHC.Unit.Module.Name (ModuleName) import GHC.Types.Basic+import GHC.Types.Var.Set (TyVarSet) import qualified Data.List.NonEmpty as NE-import Data.Typeable+import Data.Typeable hiding (TyCon) {- Note [Migrating TcM Messages]@@ -62,7 +76,6 @@ -} - -- The majority of TcRn messages come with extra context about the error, -- and this newtype captures it. See Note [Migrating TcM messages]. data ErrInfo = ErrInfo {@@ -235,7 +248,8 @@ Test cases: None. -}- TcRnSimplifierTooManyIterations :: !IntWithInf+ TcRnSimplifierTooManyIterations :: Cts+ -> !IntWithInf -- ^ The limit. -> WantedConstraints -> TcRnMessage@@ -509,6 +523,580 @@ -} TcRnOverloadedSig :: TcIdSigInfo -> TcRnMessage + {-| TcRnTupleConstraintInst is an error that occurs whenever an instance+ for a tuple constraint is specified.++ Examples(s):+ class C m a+ class D m a+ f :: (forall a. Eq a => (C m a, D m a)) => m a+ f = undefined++ Test cases: quantified-constraints/T15334+ -}+ TcRnTupleConstraintInst :: !Class -> TcRnMessage++ {-| TcRnAbstractClassInst is an error that occurs whenever an instance+ of an abstract class is specified.++ Examples(s):+ -- A.hs-boot+ module A where+ class C a++ -- B.hs+ module B where+ import {-# SOURCE #-} A+ instance C Int where++ -- A.hs+ module A where+ import B+ class C a where+ f :: a++ -- Main.hs+ import A+ main = print (f :: Int)++ Test cases: typecheck/should_fail/T13068+ -}+ TcRnAbstractClassInst :: !Class -> TcRnMessage++ {-| TcRnNoClassInstHead is an error that occurs whenever an instance+ head is not headed by a class.++ Examples(s):+ instance c++ Test cases: typecheck/rename/T5513+ typecheck/rename/T16385+ -}+ TcRnNoClassInstHead :: !Type -> TcRnMessage++ {-| TcRnUserTypeError is an error that occurs due to a user's custom type error,+ which can be triggered by adding a `TypeError` constraint in a type signature+ or typeclass instance.++ Examples(s):+ f :: TypeError (Text "This is a type error")+ f = undefined++ Test cases: typecheck/should_fail/CustomTypeErrors02+ typecheck/should_fail/CustomTypeErrors03+ -}+ TcRnUserTypeError :: !Type -> TcRnMessage++ {-| TcRnConstraintInKind is an error that occurs whenever a constraint is specified+ in a kind.++ Examples(s):+ data Q :: Eq a => Type where {}++ Test cases: dependent/should_fail/T13895+ polykinds/T16263+ saks/should_fail/saks_fail004+ typecheck/should_fail/T16059a+ typecheck/should_fail/T18714+ -}+ TcRnConstraintInKind :: !Type -> TcRnMessage++ {-| TcRnUnboxedTupleTypeFuncArg is an error that occurs whenever an unboxed tuple type+ is specified as a function argument.++ Examples(s):+ -- T15073.hs+ import T15073a+ newtype Foo a = MkFoo a+ deriving P++ -- T15073a.hs+ class P a where+ p :: a -> (# a #)++ Test cases: deriving/should_fail/T15073.hs+ deriving/should_fail/T15073a.hs+ typecheck/should_fail/T16059d+ -}+ TcRnUnboxedTupleTypeFuncArg :: !Type -> TcRnMessage++ {-| TcRnLinearFuncInKind is an error that occurs whenever a linear function is+ specified in a kind.++ Examples(s):+ data A :: * %1 -> *++ Test cases: linear/should_fail/LinearKind+ linear/should_fail/LinearKind2+ linear/should_fail/LinearKind3+ -}+ TcRnLinearFuncInKind :: !Type -> TcRnMessage++ {-| TcRnForAllEscapeError is an error that occurs whenever a quantified type's kind+ mentions quantified type variable.++ Examples(s):+ type T :: TYPE (BoxedRep l)+ data T = MkT++ Test cases: unlifted-datatypes/should_fail/UnlDataNullaryPoly+ -}+ TcRnForAllEscapeError :: !Type -> !Kind -> TcRnMessage++ {-| TcRnVDQInTermType is an error that occurs whenever a visible dependent quantification+ is specified in the type of a term.++ Examples(s):+ a = (undefined :: forall k -> k -> Type) @Int++ Test cases: dependent/should_fail/T15859+ dependent/should_fail/T16326_Fail1+ dependent/should_fail/T16326_Fail2+ dependent/should_fail/T16326_Fail3+ dependent/should_fail/T16326_Fail4+ dependent/should_fail/T16326_Fail5+ dependent/should_fail/T16326_Fail6+ dependent/should_fail/T16326_Fail7+ dependent/should_fail/T16326_Fail8+ dependent/should_fail/T16326_Fail9+ dependent/should_fail/T16326_Fail10+ dependent/should_fail/T16326_Fail11+ dependent/should_fail/T16326_Fail12+ dependent/should_fail/T17687+ dependent/should_fail/T18271+ -}+ TcRnVDQInTermType :: !Type -> TcRnMessage++ {-| TcRnIllegalEqualConstraints is an error that occurs whenever an illegal equational+ constraint is specified.++ Examples(s):+ blah :: (forall a. a b ~ a c) => b -> c+ blah = undefined++ Test cases: typecheck/should_fail/T17563+ -}+ TcRnIllegalEqualConstraints :: !Type -> TcRnMessage++ {-| TcRnBadQuantPredHead is an error that occurs whenever a quantified predicate+ lacks a class or type variable head.++ Examples(s):+ class (forall a. A t a => A t [a]) => B t where+ type A t a :: Constraint++ Test cases: quantified-constraints/T16474+ -}+ TcRnBadQuantPredHead :: !Type -> TcRnMessage++ {-| TcRnIllegalTupleConstraint is an error that occurs whenever an illegal tuple+ constraint is specified.++ Examples(s):+ g :: ((Show a, Num a), Eq a) => a -> a+ g = undefined++ Test cases: typecheck/should_fail/tcfail209a+ -}+ TcRnIllegalTupleConstraint :: !Type -> TcRnMessage++ {-| TcRnNonTypeVarArgInConstraint is an error that occurs whenever a non type-variable+ argument is specified in a constraint.++ Examples(s):+ data T+ instance Eq Int => Eq T++ Test cases: ghci/scripts/T13202+ ghci/scripts/T13202a+ polykinds/T12055a+ typecheck/should_fail/T10351+ typecheck/should_fail/T19187+ typecheck/should_fail/T6022+ typecheck/should_fail/T8883+ -}+ TcRnNonTypeVarArgInConstraint :: !Type -> TcRnMessage++ {-| TcRnIllegalImplicitParam is an error that occurs whenever an illegal implicit+ parameter is specified.++ Examples(s):+ type Bla = ?x::Int+ data T = T+ instance Bla => Eq T++ Test cases: polykinds/T11466+ typecheck/should_fail/T8912+ typecheck/should_fail/tcfail041+ typecheck/should_fail/tcfail211+ typecheck/should_fail/tcrun045+ -}+ TcRnIllegalImplicitParam :: !Type -> TcRnMessage++ {-| TcRnIllegalConstraintSynonymOfKind is an error that occurs whenever an illegal constraint+ synonym of kind is specified.++ Examples(s):+ type Showish = Show+ f :: (Showish a) => a -> a+ f = undefined++ Test cases: typecheck/should_fail/tcfail209+ -}+ TcRnIllegalConstraintSynonymOfKind :: !Type -> TcRnMessage++ {-| TcRnIllegalClassInst is an error that occurs whenever a class instance is specified+ for a non-class.++ Examples(s):+ type C1 a = (Show (a -> Bool))+ instance C1 Int where++ Test cases: polykinds/T13267+ -}+ TcRnIllegalClassInst :: !TyConFlavour -> TcRnMessage++ {-| TcRnOversaturatedVisibleKindArg is an error that occurs whenever an illegal oversaturated+ visible kind argument is specified.++ Examples(s):+ type family+ F2 :: forall (a :: Type). Type where+ F2 @a = Maybe a++ Test cases: typecheck/should_fail/T15793+ typecheck/should_fail/T16255+ -}+ TcRnOversaturatedVisibleKindArg :: !Type -> TcRnMessage++ {-| TcRnBadAssociatedType is an error that occurs whenever a class doesn't have an+ associated type.++ Examples(s):+ $(do d <- instanceD (cxt []) (conT ''Eq `appT` conT ''Foo)+ [tySynInstD $ tySynEqn Nothing (conT ''Rep `appT` conT ''Foo) (conT ''Maybe)]+ return [d])+ ======>+ instance Eq Foo where+ type Rep Foo = Maybe++ Test cases: th/T12387a+ -}+ TcRnBadAssociatedType :: {-Class-} !Name -> {-TyCon-} !Name -> TcRnMessage++ {-| TcRnForAllRankErr is an error that occurs whenever an illegal ranked type+ is specified.++ Examples(s):+ foo :: (a,b) -> (a~b => t) -> (a,b)+ foo p x = p++ Test cases:+ - ghci/should_run/T15806+ - indexed-types/should_fail/SimpleFail15+ - typecheck/should_fail/T11355+ - typecheck/should_fail/T12083a+ - typecheck/should_fail/T12083b+ - typecheck/should_fail/T16059c+ - typecheck/should_fail/T16059e+ - typecheck/should_fail/T17213+ - typecheck/should_fail/T18939_Fail+ - typecheck/should_fail/T2538+ - typecheck/should_fail/T5957+ - typecheck/should_fail/T7019+ - typecheck/should_fail/T7019a+ - typecheck/should_fail/T7809+ - typecheck/should_fail/T9196+ - typecheck/should_fail/tcfail127+ - typecheck/should_fail/tcfail184+ - typecheck/should_fail/tcfail196+ - typecheck/should_fail/tcfail197+ -}+ TcRnForAllRankErr :: !Rank -> !Type -> TcRnMessage++ {-| TcRnMonomorphicBindings is a warning (controlled by -Wmonomorphism-restriction)+ that arise when the monomorphism restriction applies to the given bindings.++ Examples(s):+ {-# OPTIONS_GHC -Wmonomorphism-restriction #-}++ bar = 10++ foo :: Int+ foo = bar++ main :: IO ()+ main = print foo++ The example above emits the warning (for 'bar'), because without monomorphism+ restriction the inferred type for 'bar' is 'bar :: Num p => p'. This warning tells us+ that /if/ we were to enable '-XMonomorphismRestriction' we would make 'bar'+ less polymorphic, as its type would become 'bar :: Int', so GHC warns us about that.++ Test cases: typecheck/should_compile/T13785+ -}+ TcRnMonomorphicBindings :: [Name] -> TcRnMessage++ {-| TcRnOrphanInstance is a warning (controlled by -Wwarn-orphans)+ that arises when a typeclass instance is an \"orphan\", i.e. if it appears+ in a module in which neither the class nor the type being instanced are+ declared in the same module.++ Examples(s): None++ Test cases: warnings/should_compile/T9178+ typecheck/should_compile/T4912+ -}+ TcRnOrphanInstance :: ClsInst -> TcRnMessage++ {-| TcRnFunDepConflict is an error that occurs when there are functional dependencies+ conflicts between instance declarations.++ Examples(s): None++ Test cases: typecheck/should_fail/T2307+ typecheck/should_fail/tcfail096+ typecheck/should_fail/tcfail202+ -}+ TcRnFunDepConflict :: !UnitState -> NE.NonEmpty ClsInst -> TcRnMessage++ {-| TcRnDupInstanceDecls is an error that occurs when there are duplicate instance+ declarations.++ Examples(s):+ class Foo a where+ foo :: a -> Int++ instance Foo Int where+ foo = id++ instance Foo Int where+ foo = const 42++ Test cases: cabal/T12733/T12733+ typecheck/should_fail/tcfail035+ typecheck/should_fail/tcfail023+ backpack/should_fail/bkpfail18+ typecheck/should_fail/TcNullaryTCFail+ typecheck/should_fail/tcfail036+ typecheck/should_fail/tcfail073+ module/mod51+ module/mod52+ module/mod44+ -}+ TcRnDupInstanceDecls :: !UnitState -> NE.NonEmpty ClsInst -> TcRnMessage++ {-| TcRnConflictingFamInstDecls is an error that occurs when there are conflicting+ family instance declarations.++ Examples(s): None.++ Test cases: indexed-types/should_fail/ExplicitForAllFams4b+ indexed-types/should_fail/NoGood+ indexed-types/should_fail/Over+ indexed-types/should_fail/OverDirectThisMod+ indexed-types/should_fail/OverIndirectThisMod+ indexed-types/should_fail/SimpleFail11a+ indexed-types/should_fail/SimpleFail11b+ indexed-types/should_fail/SimpleFail11c+ indexed-types/should_fail/SimpleFail11d+ indexed-types/should_fail/SimpleFail2a+ indexed-types/should_fail/SimpleFail2b+ indexed-types/should_fail/T13092/T13092+ indexed-types/should_fail/T13092c/T13092c+ indexed-types/should_fail/T14179+ indexed-types/should_fail/T2334A+ indexed-types/should_fail/T2677+ indexed-types/should_fail/T3330b+ indexed-types/should_fail/T4246+ indexed-types/should_fail/T7102a+ indexed-types/should_fail/T9371+ polykinds/T7524+ typecheck/should_fail/UnliftedNewtypesOverlap+ -}+ TcRnConflictingFamInstDecls :: NE.NonEmpty FamInst -> TcRnMessage++ TcRnFamInstNotInjective :: InjectivityErrReason -> TyCon -> NE.NonEmpty CoAxBranch -> TcRnMessage++ {-| TcRnBangOnUnliftedType is a warning (controlled by -Wredundant-strictness-flags) that+ occurs when a strictness annotation is applied to an unlifted type.++ Example(s):+ data T = MkT !Int# -- Strictness flag has no effect on unlifted types++ Test cases: typecheck/should_compile/T20187a+ typecheck/should_compile/T20187b+ -}+ TcRnBangOnUnliftedType :: !Type -> TcRnMessage++ {-| TcRnMultipleDefaultDeclarations is an error that occurs when a module has+ more than one default declaration.++ Example:+ default (Integer, Int)+ default (Double, Float) -- 2nd default declaration not allowed++ Text cases: module/mod58+ -}+ TcRnMultipleDefaultDeclarations :: [LDefaultDecl GhcRn] -> TcRnMessage++ {-| TcRnBadDefaultType is an error that occurs when a type used in a default+ declaration does not have an instance for any of the applicable classes.++ Example(s):+ data Foo+ default (Foo)++ Test cases: typecheck/should_fail/T11974b+ -}+ TcRnBadDefaultType :: Type -> [Class] -> TcRnMessage++ {-| TcRnPatSynBundledWithNonDataCon is an error that occurs when a module's+ export list bundles a pattern synonym with a type that is not a proper+ `data` or `newtype` construction.++ Example(s):+ module Foo (MyClass(.., P)) where+ pattern P = Nothing+ class MyClass a where+ foo :: a -> Int++ Test cases: patsyn/should_fail/export-class+ -}+ TcRnPatSynBundledWithNonDataCon :: TcRnMessage++ {-| TcRnPatSynBundledWithWrongType is an error that occurs when the export list+ of a module has a pattern synonym bundled with a type that does not match+ the type of the pattern synonym.++ Example(s):+ module Foo (R(P,x)) where+ data Q = Q Int+ data R = R+ pattern P{x} = Q x++ Text cases: patsyn/should_fail/export-ps-rec-sel+ patsyn/should_fail/export-type-synonym+ patsyn/should_fail/export-type+ -}+ TcRnPatSynBundledWithWrongType :: Type -> Type -> TcRnMessage++ {-| TcRnDupeModuleExport is a warning controlled by @-Wduplicate-exports@ that+ occurs when a module appears more than once in an export list.++ Example(s):+ module Foo (module Bar, module Bar)+ import Bar++ Text cases: None+ -}+ TcRnDupeModuleExport :: ModuleName -> TcRnMessage++ {-| TcRnExportedModNotImported is an error that occurs when an export list+ contains a module that is not imported.++ Example(s): None++ Text cases: module/mod135+ module/mod8+ rename/should_fail/rnfail028+ backpack/should_fail/bkpfail48+ -}+ TcRnExportedModNotImported :: ModuleName -> TcRnMessage++ {-| TcRnNullExportedModule is a warning controlled by -Wdodgy-exports that occurs+ when an export list contains a module that has no exports.++ Example(s):+ module Foo (module Bar) where+ import Bar ()++ Test cases: None+ -}+ TcRnNullExportedModule :: ModuleName -> TcRnMessage++ {-| TcRnMissingExportList is a warning controlled by -Wmissing-export-lists that+ occurs when a module does not have an explicit export list.++ Example(s): None++ Test cases: typecheck/should_fail/MissingExportList03+ -}+ TcRnMissingExportList :: ModuleName -> TcRnMessage++ {-| TcRnExportHiddenComponents is an error that occurs when an export contains+ constructor or class methods that are not visible.++ Example(s): None++ Test cases: None+ -}+ TcRnExportHiddenComponents :: IE GhcPs -> TcRnMessage++ {-| TcRnDuplicateExport is a warning (controlled by -Wduplicate-exports) that occurs+ when an identifier appears in an export list more than once.++ Example(s): None++ Test cases: module/MultiExport+ module/mod128+ module/mod14+ module/mod5+ overloadedrecflds/should_fail/DuplicateExports+ patsyn/should_compile/T11959+ -}+ TcRnDuplicateExport :: GreName -> IE GhcPs -> IE GhcPs -> TcRnMessage++ {-| TcRnExportedParentChildMismatch is an error that occurs when an export is+ bundled with a parent that it does not belong to++ Example(s):+ module Foo (T(a)) where+ data T+ a = True++ Test cases: module/T11970+ module/T11970B+ module/mod17+ module/mod3+ overloadedrecflds/should_fail/NoParent+ -}+ TcRnExportedParentChildMismatch :: Name -> TyThing -> GreName -> [Name] -> TcRnMessage++ {-| TcRnConflictingExports is an error that occurs when different identifiers that+ have the same name are being exported by a module.++ Example(s):+ module Foo (Bar.f, module Baz) where+ import qualified Bar (f)+ import Baz (f)++ Test cases: module/mod131+ module/mod142+ module/mod143+ module/mod144+ module/mod145+ module/mod146+ module/mod150+ module/mod155+ overloadedrecflds/should_fail/T14953+ overloadedrecflds/should_fail/overloadedrecfldsfail10+ rename/should_fail/rnfail029+ rename/should_fail/rnfail040+ typecheck/should_fail/T16453E2+ typecheck/should_fail/tcfail025+ typecheck/should_fail/tcfail026+ -}+ TcRnConflictingExports+ :: OccName -- ^ Occurrence name shared by both exports+ -> GreName -- ^ Name of first export+ -> GlobalRdrElt -- ^ Provenance for definition site of first export+ -> IE GhcPs -- ^ Export decl of first export+ -> GreName -- ^ Name of second export+ -> GlobalRdrElt -- ^ Provenance for definition site of second export+ -> IE GhcPs -- ^ Export decl of second export+ -> TcRnMessage+ -- | Which parts of a record field are affected by a particular error or warning. data RecordFieldPart = RecordFieldConstructor !Name@@ -538,3 +1126,28 @@ | LevityCheckInValidDataCon | LevityCheckInValidClass +-- | Why the particular injectivity error arose together with more information,+-- if any.+data InjectivityErrReason+ = InjErrRhsBareTyVar [Type]+ | InjErrRhsCannotBeATypeFam+ | InjErrRhsOverlap+ | InjErrCannotInferFromRhs !TyVarSet !HasKinds !SuggestUndecidableInstances++data HasKinds+ = YesHasKinds+ | NoHasKinds+ deriving (Show, Eq)++hasKinds :: Bool -> HasKinds+hasKinds True = YesHasKinds+hasKinds False = NoHasKinds++data SuggestUndecidableInstances+ = YesSuggestUndecidableInstaces+ | NoSuggestUndecidableInstaces+ deriving (Show, Eq)++suggestUndecidableInstances :: Bool -> SuggestUndecidableInstances+suggestUndecidableInstances True = YesSuggestUndecidableInstaces+suggestUndecidableInstances False = NoSuggestUndecidableInstaces
compiler/GHC/Tc/Types.hs view
@@ -42,7 +42,7 @@ -- Renamer types ErrCtxt, RecFieldEnv, pushErrCtxt, pushErrCtxtSameOrigin, ImportAvails(..), emptyImportAvails, plusImportAvails,- WhereFrom(..), mkModDeps, modDepsElts,+ WhereFrom(..), mkModDeps, -- Typechecker types TcTypeEnv, TcBinderStack, TcBinder(..),@@ -59,6 +59,7 @@ topStage, topAnnStage, topSpliceStage, ThLevel, impLevel, outerLevel, thLevel, ForeignSrcLang(..), THDocs, DocLoc(..),+ ThBindEnv, -- Arrows ArrowCtxt(..),@@ -146,7 +147,7 @@ import GHC.Unit import GHC.Unit.Module.Warnings-import GHC.Unit.Module.Imported+import GHC.Unit.Module.Deps import GHC.Unit.Module.ModDetails import GHC.Utils.Error@@ -1365,70 +1366,7 @@ ************************************************************************ -} --- | 'ImportAvails' summarises what was imported from where, irrespective of--- whether the imported things are actually used or not. It is used:------ * when processing the export list,------ * when constructing usage info for the interface file,------ * to identify the list of directly imported modules for initialisation--- purposes and for optimised overlap checking of family instances,------ * when figuring out what things are really unused----data ImportAvails- = ImportAvails {- imp_mods :: ImportedMods,- -- = ModuleEnv [ImportedModsVal],- -- ^ Domain is all directly-imported modules- --- -- See the documentation on ImportedModsVal in- -- "GHC.Unit.Module.Imported" for the meaning of the fields.- --- -- We need a full ModuleEnv rather than a ModuleNameEnv here,- -- because we might be importing modules of the same name from- -- different packages. (currently not the case, but might be in the- -- future). - imp_direct_dep_mods :: ModuleNameEnv ModuleNameWithIsBoot,- -- ^ Home-package modules directly imported by the module being compiled.-- imp_dep_direct_pkgs :: Set UnitId,- -- ^ Packages directly needed by the module being compiled-- imp_trust_own_pkg :: Bool,- -- ^ Do we require that our own package is trusted?- -- This is to handle efficiently the case where a Safe module imports- -- a Trustworthy module that resides in the same package as it.- -- See Note [Trust Own Package] in "GHC.Rename.Names"-- -- Transitive information below here-- imp_trust_pkgs :: Set UnitId,- -- ^ This records the- -- packages the current module needs to trust for Safe Haskell- -- compilation to succeed. A package is required to be trusted if- -- we are dependent on a trustworthy module in that package.- -- See Note [Tracking Trust Transitively] in "GHC.Rename.Names"-- imp_boot_mods :: ModuleNameEnv ModuleNameWithIsBoot,- -- ^ Domain is all modules which have hs-boot files, and whether- -- we should import the boot version of interface file. Only used- -- in one-shot mode to populate eps_is_boot.-- imp_sig_mods :: [ModuleName],- -- ^ Signature modules below this one-- imp_orphs :: [Module],- -- ^ Orphan modules below us in the import tree (and maybe including- -- us for imported modules)-- imp_finsts :: [Module]- -- ^ Family instance modules below us in the import tree (and maybe- -- including us for imported modules)- }- mkModDeps :: Set ModuleNameWithIsBoot -> ModuleNameEnv ModuleNameWithIsBoot mkModDeps deps = S.foldl' add emptyUFM deps@@ -1448,13 +1386,6 @@ -- If either side can "see" a non-hi-boot interface, use that -- Reusing existing tuples saves 10% of allocations on test -- perf/compiler/MultiLayerModules--modDepsElts- :: ModuleNameEnv ModuleNameWithIsBoot- -> Set ModuleNameWithIsBoot-modDepsElts = S.fromList . nonDetEltsUFM- -- It's OK to use nonDetEltsUFM here because sorting by module names- -- restores determinism emptyImportAvails :: ImportAvails emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv,
compiler/GHC/Tc/Types/Origin.hs view
@@ -220,7 +220,7 @@ | FamInstSkol -- Bound at a family instance decl | PatSkol -- An existential type variable bound by a pattern for ConLike -- a data constructor with an existential type.- (HsMatchContext GhcRn)+ (HsMatchContext GhcTc) -- e.g. data T = forall a. Eq a => MkT a -- f (MkT x) = ... -- The pattern MkT x will allocate an existential type@@ -540,8 +540,6 @@ exprCtOrigin (HsSpliceE {}) = Shouldn'tHappenOrigin "TH splice" exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc" exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression"-exprCtOrigin (HsTick _ _ e) = lexprCtOrigin e-exprCtOrigin (HsBinTick _ _ _ e) = lexprCtOrigin e exprCtOrigin (XExpr (HsExpanded a _)) = exprCtOrigin a -- | Extract a suitable CtOrigin from a MatchGroup
+ compiler/GHC/Tc/Types/Rank.hs view
@@ -0,0 +1,40 @@+module GHC.Tc.Types.Rank (Rank(..)) where++import GHC.Base (Bool)+import GHC.Utils.Outputable (Outputable, (<+>), parens, ppr, text)++{-+Note [Higher rank types]+~~~~~~~~~~~~~~~~~~~~~~~~+Technically+ Int -> forall a. a->a+is still a rank-1 type, but it's not Haskell 98 (#5957). So the+validity checker allow a forall after an arrow only if we allow it+before -- that is, with Rank2Types or RankNTypes+-}++data Rank = ArbitraryRank -- Any rank ok++ | LimitedRank -- Note [Higher rank types]+ Bool -- Forall ok at top+ Rank -- Use for function arguments++ -- Monotypes that could be a polytype through an extension+ | MonoTypeRankZero -- RankNTypes+ | MonoTypeTyConArg -- ImpredicativeTypes+ | MonoTypeSynArg -- LiberalTypeSynonyms+ | MonoTypeConstraint -- QuantifiedConstraints+ --++ | MustBeMonoType -- Monotype regardless of flags++instance Outputable Rank where+ ppr ArbitraryRank = text "ArbitraryRank"+ ppr (LimitedRank top_forall_ok r)+ = text "LimitedRank" <+> ppr top_forall_ok+ <+> parens (ppr r)+ ppr MonoTypeRankZero = text "MonoTypeRankZero"+ ppr MonoTypeTyConArg = text "MonoTypeTyConArg"+ ppr MonoTypeSynArg = text "MonoTypeSynArg"+ ppr MonoTypeConstraint = text "MonoTypeConstraint"+ ppr MustBeMonoType = text "MustBeMonoType"
compiler/GHC/Tc/Utils/TcType.hs view
@@ -625,6 +625,10 @@ But in fact (GivenInv) is automatically true, so we're adhering to it for now. See #18929. +* If a tyvar tv has level n, then the levels of all variables free+ in tv's kind are <= n. Consequence: if tv is untouchable, so are+ all variables in tv's kind.+ Note [WantedInv] ~~~~~~~~~~~~~~~~ Why is WantedInv important? Consider this implication, where@@ -1591,6 +1595,7 @@ -> Type -> Type -> Bool -- Flags False, False is the usual setting for tc_eq_type+-- See Note [Computing equality on types] in Type tc_eq_type keep_syns vis_only orig_ty1 orig_ty2 = go orig_env orig_ty1 orig_ty2 where@@ -1620,10 +1625,14 @@ -- Make sure we handle all FunTy cases since falling through to the -- AppTy case means that tcRepSplitAppTy_maybe may see an unzonked -- kind variable, which causes things to blow up.+ -- See Note [Equality on FunTys] in GHC.Core.TyCo.Rep: we must check+ -- kinds here go env (FunTy _ w1 arg1 res1) (FunTy _ w2 arg2 res2)- = go env w1 w2 && go env arg1 arg2 && go env res1 res2- go env ty (FunTy _ w arg res) = eqFunTy env w arg res ty- go env (FunTy _ w arg res) ty = eqFunTy env w arg res ty+ = kinds_eq && go env arg1 arg2 && go env res1 res2 && go env w1 w2+ where+ kinds_eq | vis_only = True+ | otherwise = go env (typeKind arg1) (typeKind arg2) &&+ go env (typeKind res1) (typeKind res2) -- See Note [Equality on AppTys] in GHC.Core.Type go env (AppTy s1 t1) ty2@@ -1658,25 +1667,6 @@ orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2] - -- @eqFunTy w arg res ty@ is True when @ty@ equals @FunTy w arg res@. This is- -- sometimes hard to know directly because @ty@ might have some casts- -- obscuring the FunTy. And 'splitAppTy' is difficult because we can't- -- always extract a RuntimeRep (see Note [xyz]) if the kind of the arg or- -- res is unzonked. Thus this function, which handles this- -- corner case.- eqFunTy :: RnEnv2 -> Mult -> Type -> Type -> Type -> Bool- -- Last arg is /not/ FunTy- eqFunTy env w arg res ty@(AppTy{}) = get_args ty []- where- get_args :: Type -> [Type] -> Bool- get_args (AppTy f x) args = get_args f (x:args)- get_args (CastTy t _) args = get_args t args- get_args (TyConApp tc tys) args- | tc == funTyCon- , [w', _, _, arg', res'] <- tys ++ args- = go env w w' && go env arg arg' && go env res res'- get_args _ _ = False- eqFunTy _ _ _ _ _ = False {-# INLINE tc_eq_type #-} -- See Note [Specialising tc_eq_type]. {- Note [Typechecker equality vs definitional equality]
compiler/GHC/Tc/Utils/TcType.hs-boot view
@@ -1,8 +1,12 @@ module GHC.Tc.Utils.TcType where import GHC.Utils.Outputable( SDoc )+import GHC.Prelude ( Bool )+import {-# SOURCE #-} GHC.Types.Var ( TcTyVar ) data MetaDetails data TcTyVarDetails pprTcTyVarDetails :: TcTyVarDetails -> SDoc vanillaSkolemTv :: TcTyVarDetails+isMetaTyVar :: TcTyVar -> Bool+isTyConableTyVar :: TcTyVar -> Bool
compiler/GHC/Types/Avail.hs view
@@ -349,9 +349,9 @@ -- will give Ix(Ix,index,range) and Ix(index) -- We want to combine these; addAvail does that nubAvails :: [AvailInfo] -> [AvailInfo]-nubAvails avails = nameEnvElts (foldl' add emptyNameEnv avails)+nubAvails avails = eltsDNameEnv (foldl' add emptyDNameEnv avails) where- add env avail = extendNameEnv_C plusAvail env (availName avail) avail+ add env avail = extendDNameEnv_C plusAvail env (availName avail) avail -- ----------------------------------------------------------------------------- -- Printing
compiler/GHC/Types/Basic.hs view
@@ -95,7 +95,7 @@ SuccessFlag(..), succeeded, failed, successIf, - IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit,+ IntWithInf, infinity, treatZeroAsInf, subWithInf, mkIntWithInf, intGtLimit, SpliceExplicitFlag(..), @@ -1698,6 +1698,11 @@ mulWithInf Infinity _ = Infinity mulWithInf _ Infinity = Infinity mulWithInf (Int a) (Int b) = Int (a * b)++-- | Subtract an 'Int' from an 'IntWithInf'+subWithInf :: IntWithInf -> Int -> IntWithInf+subWithInf Infinity _ = Infinity+subWithInf (Int a) b = Int (a - b) -- | Turn a positive number into an 'IntWithInf', where 0 represents infinity treatZeroAsInf :: Int -> IntWithInf
compiler/GHC/Types/Cpr.hs view
@@ -33,6 +33,8 @@ -- If all of them are top, better use 'FlatConCpr', as ensured by the pattern -- synonym 'ConCpr'. | FlatConCpr !ConTag+ -- ^ @FlatConCpr tag@ is an efficient encoding for @'ConCpr_' tag [TopCpr..]@.+ -- Purely for compiler perf. Can be constructed with 'ConCpr'. | TopCpr deriving Eq @@ -169,12 +171,9 @@ -- unleashable at that arity. See Note [Understanding DmdType and DmdSig] in -- "GHC.Types.Demand" mkCprSigForArity :: Arity -> CprType -> CprSig-mkCprSigForArity arty ty@(CprType n cpr)- | arty /= n = topCprSig- -- Trim on arity mismatch- | ConCpr t _ <- cpr = CprSig (CprType n (flatConCpr t))- -- Flatten nested CPR info, we don't exploit it (yet)- | otherwise = CprSig ty+mkCprSigForArity arty ty@(CprType n _)+ | arty /= n = topCprSig -- Trim on arity mismatch+ | otherwise = CprSig ty topCprSig :: CprSig topCprSig = CprSig topCprType@@ -189,14 +188,14 @@ seqCprSig (CprSig ty) = seqCprTy ty -- | BNF:--- ```--- cpr ::= '' -- TopCpr--- | n -- FlatConCpr n--- | n '(' cpr1 ',' cpr2 ',' ... ')' -- ConCpr n [cpr1,cpr2,...]--- | 'b' -- BotCpr--- ```+--+-- > cpr ::= '' -- TopCpr+-- > | n -- FlatConCpr n+-- > | n '(' cpr1 ',' cpr2 ',' ... ')' -- ConCpr n [cpr1,cpr2,...]+-- > | 'b' -- BotCpr+-- -- Examples:--- * `f x = f x` has denotation `b`+-- * `f x = f x` has result CPR `b` -- * `1(1,)` is a valid (nested) 'Cpr' denotation for `(I# 42#, f 42)`. instance Outputable Cpr where ppr TopCpr = empty@@ -204,8 +203,18 @@ ppr (ConCpr n cs) = int n <> parens (pprWithCommas ppr cs) ppr BotCpr = char 'b' +-- | BNF:+--+-- > cpr_ty ::= cpr -- short form if arty == 0+-- > | '\' arty '.' cpr -- if arty > 0+--+-- Examples:+-- * `f x y z = f x y z` has denotation `\3.b`+-- * `g !x = (x+1, x+2)` has denotation `\1.1(1,1)`. instance Outputable CprType where- ppr (CprType arty res) = ppr arty <> ppr res+ ppr (CprType arty res)+ | 0 <- arty = ppr res+ | otherwise = char '\\' <> ppr arty <> char '.' <> ppr res -- | Only print the CPR result instance Outputable CprSig where
compiler/GHC/Types/Demand.hs view
@@ -1875,7 +1875,7 @@ seqDmdEnv env `seq` seqDemandList ds `seq` res `seq` () seqDmdEnv :: DmdEnv -> ()-seqDmdEnv env = seqEltsUFM seqDemandList env+seqDmdEnv env = seqEltsUFM seqDemand env seqDmdSig :: DmdSig -> () seqDmdSig (DmdSig ty) = seqDmdType ty
compiler/GHC/Types/Error.hs view
@@ -33,6 +33,7 @@ -- * Hints and refactoring actions , GhcHint (..)+ , AvailableBindings(..) , LanguageExtensionHint(..) , suggestExtension , suggestExtensionWithInfo
compiler/GHC/Types/Hint.hs view
@@ -2,6 +2,7 @@ module GHC.Types.Hint ( GhcHint(..)+ , AvailableBindings(..) , InstantiationSuggestion(..) , LanguageExtensionHint(..) , suggestExtension@@ -14,6 +15,8 @@ import GHC.Prelude +import qualified Data.List.NonEmpty as NE+ import GHC.Utils.Outputable import qualified GHC.LanguageExtensions as LangExt import Data.Typeable@@ -27,6 +30,12 @@ -- This {-# SOURCE #-} import should be removable once -- 'Language.Haskell.Syntax.Bind' no longer depends on 'GHC.Tc.Types.Evidence'. +-- | The bindings we have available in scope when+-- suggesting an explicit type signature.+data AvailableBindings+ = NamedBindings (NE.NonEmpty Name)+ | UnnamedBinding+ -- ^ An unknown binding (i.e. too complicated to turn into a 'Name') data LanguageExtensionHint = -- | Suggest to enable the input extension. If the input 'SDoc'@@ -177,7 +186,7 @@ {-| Suggests adding a type signature, typically to resolve ambiguity or help GHC inferring types. -}- | SuggestAddTypeSignature+ | SuggestAddTypeSignatures AvailableBindings {-| Suggests to explicitly discard the result of a monadic action by binding the result to the '_' wilcard. @@ -251,6 +260,14 @@ Test case(s): parser/should_fail/T3811 -} | SuggestTypeSignatureForm++ {-| Suggests to move an orphan instance or to newtype-wrap it.++ Triggered by: 'GHC.Tc.Errors.Types.TcRnOrphanInstance'+ Test cases(s): warnings/should_compile/T9178+ typecheck/should_compile/T4912+ -}+ | SuggestFixOrphanInstance -- | An 'InstantiationSuggestion' for a '.hsig' file. This is generated -- by GHC in case of a 'DriverUnexpectedSignature' and suggests a way
compiler/GHC/Types/Hint/Ppr.hs view
@@ -18,6 +18,7 @@ import GHC.Utils.Outputable import Data.List (intersperse)+import qualified Data.List.NonEmpty as NE instance Outputable GhcHint where ppr = \case@@ -29,10 +30,10 @@ (text "Perhaps you intended to use" <+> ppr ext) $$ extraUserInfo SuggestAnyExtension extraUserInfo exts -> let header = text "Enable any of the following extensions:"- in header <+> hsep (intersperse (char ',') (map ppr exts)) $$ extraUserInfo+ in header <+> hcat (intersperse (text ", ") (map ppr exts)) $$ extraUserInfo SuggestExtensions extraUserInfo exts -> let header = text "Enable all of the following extensions:"- in header <+> hsep (intersperse (char ',') (map ppr exts)) $$ extraUserInfo+ in header <+> hcat (intersperse (text ", ") (map ppr exts)) $$ extraUserInfo SuggestMissingDo -> text "Possibly caused by a missing 'do'?" SuggestLetInDo@@ -63,8 +64,19 @@ -> text "Use parentheses." SuggestIncreaseMaxPmCheckModels -> text "Increase the limit or resolve the warnings to suppress this message."- SuggestAddTypeSignature- -> text "Add a type signature."+ SuggestAddTypeSignatures bindings+ -> case bindings of+ -- This might happen when we have bindings which are /too complicated/,+ -- see for example 'DsCannotMixPolyAndUnliftedBindings' in 'GHC.HsToCore.Errors.Types'.+ -- In this case, we emit a generic message.+ UnnamedBinding -> text "Add a type signature."+ NamedBindings (x NE.:| xs) ->+ let nameList = case xs of+ [] -> quotes . ppr $ x+ _ -> pprWithCommas (quotes . ppr) xs <+> text "and" <+> quotes (ppr x)+ in hsep [ text "Consider giving"+ , nameList+ , text "a type signature"] SuggestBindToWildcard rhs -> hang (text "Suppress this warning by saying") 2 (quotes $ text "_ <-" <+> ppr rhs) SuggestAddInlineOrNoInlinePragma lhs_id rule_act@@ -104,6 +116,10 @@ in case mb_mod of Nothing -> header <+> text "the hsig file." Just mod -> header <+> ppr (moduleName mod) <> text "'s hsig file."+ SuggestFixOrphanInstance+ -> vcat [ text "Move the instance declaration to the module of the class or of the type, or"+ , text "wrap the type with a newtype and declare the instance on the new type."+ ] perhapsAsPat :: SDoc perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"
compiler/GHC/Types/IPE.hs view
@@ -1,5 +1,10 @@-module GHC.Types.IPE(DCMap, ClosureMap, InfoTableProvMap(..)- , emptyInfoTableProvMap) where+module GHC.Types.IPE (+ DCMap,+ ClosureMap,+ InfoTableProvMap(..),+ emptyInfoTableProvMap,+ IpeSourceLocation+) where import GHC.Prelude @@ -10,11 +15,17 @@ import GHC.Types.Unique.Map import GHC.Core.Type import Data.List.NonEmpty+import GHC.Cmm.CLabel (CLabel)+import qualified Data.Map.Strict as Map +-- | Position and information about an info table.+-- For return frames these are the contents of a 'CoreSyn.SourceNote'.+type IpeSourceLocation = (RealSrcSpan, String)+ -- | A map from a 'Name' to the best approximate source position that -- name arose from. type ClosureMap = UniqMap Name -- The binding- (Type, Maybe (RealSrcSpan, String))+ (Type, Maybe IpeSourceLocation) -- The best approximate source position. -- (rendered type, source position, source note -- label)@@ -26,11 +37,15 @@ -- the constructor was used at, if possible and a string which names -- the source location. This is the same information as is the payload -- for the 'GHC.Core.SourceNote' constructor.-type DCMap = UniqMap DataCon (NonEmpty (Int, Maybe (RealSrcSpan, String)))+type DCMap = UniqMap DataCon (NonEmpty (Int, Maybe IpeSourceLocation)) +type InfoTableToSourceLocationMap = Map.Map CLabel (Maybe IpeSourceLocation)+ data InfoTableProvMap = InfoTableProvMap { provDC :: DCMap- , provClosure :: ClosureMap }+ , provClosure :: ClosureMap+ , provInfoTables :: InfoTableToSourceLocationMap+ } emptyInfoTableProvMap :: InfoTableProvMap-emptyInfoTableProvMap = InfoTableProvMap emptyUniqMap emptyUniqMap+emptyInfoTableProvMap = InfoTableProvMap emptyUniqMap emptyUniqMap Map.empty
compiler/GHC/Types/Id.hs view
@@ -296,8 +296,7 @@ -- | For an explanation of global vs. local 'Id's, see "GHC.Types.Var#globalvslocal" mkLocalId :: HasDebugCallStack => Name -> Mult -> Type -> Id-mkLocalId name w ty = assert (not (isCoVarType ty)) $- mkLocalIdWithInfo name w ty vanillaIdInfo+mkLocalId name w ty = mkLocalIdWithInfo name w (assert (not (isCoVarType ty)) ty) vanillaIdInfo -- | Make a local CoVar mkLocalCoVar :: Name -> Type -> CoVar@@ -318,8 +317,8 @@ -- proper ids only; no covars! mkLocalIdWithInfo :: HasDebugCallStack => Name -> Mult -> Type -> IdInfo -> Id-mkLocalIdWithInfo name w ty info = assert (not (isCoVarType ty)) $- Var.mkLocalVar VanillaId name w ty info+mkLocalIdWithInfo name w ty info =+ Var.mkLocalVar VanillaId name w (assert (not (isCoVarType ty)) ty) info -- Note [Free type variables] -- | Create a local 'Id' that is marked as exported.
compiler/GHC/Types/Id/Info.hs view
@@ -89,9 +89,7 @@ import GHC.Prelude -import GHC.Core hiding( hasCoreUnfolding )-import GHC.Core( hasCoreUnfolding )-+import GHC.Core import GHC.Core.Class import {-# SOURCE #-} GHC.Builtin.PrimOps (PrimOp) import GHC.Types.Name@@ -689,8 +687,10 @@ -- ^ Zaps any core unfolding, but /preserves/ evaluated-ness, -- i.e. an unfolding of OtherCon zapFragileUnfolding unf- | hasCoreUnfolding unf = noUnfolding- | otherwise = unf+ -- N.B. isEvaldUnfolding catches *both* OtherCon [] *and* core unfoldings+ -- representing values.+ | isEvaldUnfolding unf = evaldUnfolding+ | otherwise = noUnfolding zapUnfolding :: Unfolding -> Unfolding -- Squash all unfolding info, preserving only evaluated-ness
compiler/GHC/Types/Id/Make.hs view
@@ -581,7 +581,6 @@ ----------- Workers for data types -------------- alg_wkr_info = noCafIdInfo `setArityInfo` wkr_arity- `setCprSigInfo` mkCprSig wkr_arity (dataConCPR data_con) `setInlinePragInfo` wkr_inline_prag `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, -- even if arity = 0@@ -608,31 +607,6 @@ mkLams univ_tvs $ Lam id_arg1 $ wrapNewTypeBody tycon res_ty_args (Var id_arg1) -dataConCPR :: DataCon -> Cpr-dataConCPR con- | isDataTyCon tycon -- Real data types only; that is,- -- not unboxed tuples or newtypes- , null (dataConExTyCoVars con) -- No existentials- , wkr_arity > 0- , wkr_arity <= mAX_CPR_SIZE- = flatConCpr (dataConTag con)- | otherwise- = topCpr- where- tycon = dataConTyCon con- wkr_arity = dataConRepArity con-- mAX_CPR_SIZE :: Arity- mAX_CPR_SIZE = 10- -- We do not treat very big tuples as CPR-ish:- -- a) for a start we get into trouble because there aren't- -- "enough" unboxed tuple types (a tiresome restriction,- -- but hard to fix),- -- b) more importantly, big unboxed tuples get returned mainly- -- on the stack, and are often then allocated in the heap- -- by the caller. So doing CPR for them may in fact make- -- things worse.- {- ------------------------------------------------- -- Data constructor representation@@ -709,7 +683,6 @@ `setInlinePragInfo` wrap_prag `setUnfoldingInfo` wrap_unf `setDmdSigInfo` wrap_sig- `setCprSigInfo` mkCprSig wrap_arity (dataConCPR data_con) -- We need to get the CAF info right here because GHC.Iface.Tidy -- does not tidy the IdInfo of implicit bindings (like the wrapper) -- so it not make sure that the CAF info is sane
compiler/GHC/Types/Literal.hs view
@@ -31,7 +31,7 @@ , mkLitWord64, mkLitWord64Wrap, mkLitWord64Unchecked , mkLitFloat, mkLitDouble , mkLitChar, mkLitString- , mkLitInteger, mkLitNatural+ , mkLitBigNat , mkLitNumber, mkLitNumberWrap -- ** Operations on Literals@@ -67,7 +67,6 @@ import GHC.Prelude import GHC.Builtin.Types.Prim-import {-# SOURCE #-} GHC.Builtin.Types import GHC.Core.Type import GHC.Utils.Outputable import GHC.Data.FastString@@ -162,8 +161,7 @@ -- | Numeric literal type data LitNumType- = LitNumInteger -- ^ @Integer@ (see Note [BigNum literals])- | LitNumNatural -- ^ @Natural@ (see Note [BigNum literals])+ = LitNumBigNat -- ^ @Bignat@ (see Note [BigNum literals]) | LitNumInt -- ^ @Int#@ - according to target machine | LitNumInt8 -- ^ @Int8#@ - exactly 8 bits | LitNumInt16 -- ^ @Int16#@ - exactly 16 bits@@ -179,8 +177,7 @@ -- | Indicate if a numeric literal type supports negative numbers litNumIsSigned :: LitNumType -> Bool litNumIsSigned nt = case nt of- LitNumInteger -> True- LitNumNatural -> False+ LitNumBigNat -> False LitNumInt -> True LitNumInt8 -> True LitNumInt16 -> True@@ -195,8 +192,7 @@ -- | Number of bits litNumBitSize :: Platform -> LitNumType -> Maybe Word litNumBitSize platform nt = case nt of- LitNumInteger -> Nothing- LitNumNatural -> Nothing+ LitNumBigNat -> Nothing LitNumInt -> Just (fromIntegral (platformWordSizeInBits platform)) LitNumInt8 -> Just 8 LitNumInt16 -> Just 16@@ -217,17 +213,29 @@ {- Note [BigNum literals] ~~~~~~~~~~~~~~~~~~~~~~-GHC supports 2 kinds of arbitrary precision integers (a.k.a BigNum):+GHC supports 2 kinds of arbitrary precision numbers (a.k.a BigNum): - * Natural: natural represented as a Word# or as a BigNat+ * data Natural = NS Word# | NB BigNat# - * Integer: integer represented a an Int# or as a BigNat (Integer's- constructors indicate the sign)+ * data Integer = IS Int# | IN BigNat# | IP BigNat# -BigNum literal instances are removed from Core during the CorePrep phase. They-are replaced with expression to build them at runtime from machine literals-(Word#, Int#, etc.) or from a list of Word#s.+In the past, we had Core constructors to represent Integer and Natural literals.+These literals were then lowered into their real Core representation only in+Core prep. The issue with this approach is that literals have two+representations and we have to ensure that we handle them the same everywhere+(in every optimisation, etc.). +For example (0 :: Integer) was representable in Core with both:++ Lit (LitNumber LitNumInteger 0) -- literal+ App (Var integerISDataCon) (Lit (LitNumber LitNumInt 0)) -- real representation++Nowadays we always use the real representation for Integer and Natural literals.+However we still have two representations for BigNat# literals. BigNat# literals+are still lowered in Core prep into a call to a constructor function (BigNat# is+ByteArray# and we don't have ByteArray# literals yet so we have to build them at+runtime).+ Note [String literals] ~~~~~~~~~~~~~~~~~~~~~~ String literals are UTF-8 encoded and stored into ByteStrings in the following@@ -340,9 +348,8 @@ LitNumWord16 -> wrap @Word16 LitNumWord32 -> wrap @Word32 LitNumWord64 -> wrap @Word64- LitNumInteger -> LitNumber nt i- LitNumNatural- | i < 0 -> panic "mkLitNumberWrap: trying to create a negative Natural"+ LitNumBigNat+ | i < 0 -> panic "mkLitNumberWrap: trying to create a negative BigNat" | otherwise -> LitNumber nt i where wrap :: forall a. (Integral a, Num a) => Literal@@ -389,8 +396,7 @@ LitNumWord16 -> bounded_range @Word16 LitNumWord32 -> bounded_range @Word32 LitNumWord64 -> bounded_range @Word64- LitNumNatural -> (Just 0, Nothing)- LitNumInteger -> (Nothing, Nothing)+ LitNumBigNat -> (Just 0, Nothing) where bounded_range :: forall a . (Integral a, Bounded a) => (Maybe Integer,Maybe Integer) bounded_range = case boundedRange @a of@@ -572,20 +578,14 @@ -- stored UTF-8 encoded mkLitString s = LitString (bytesFS $ mkFastString s) -mkLitInteger :: Integer -> Literal-mkLitInteger x = LitNumber LitNumInteger x--mkLitNatural :: Integer -> Literal-mkLitNatural x = assertPpr (inNaturalRange x) (integer x)- (LitNumber LitNumNatural x)+mkLitBigNat :: Integer -> Literal+mkLitBigNat x = assertPpr (x >= 0) (integer x)+ (LitNumber LitNumBigNat x) isLitRubbish :: Literal -> Bool isLitRubbish (LitRubbish {}) = True isLitRubbish _ = False -inNaturalRange :: Integer -> Bool-inNaturalRange x = x >= 0- inBoundedRange :: forall a. (Bounded a, Integral a) => Integer -> Bool inBoundedRange x = x >= toInteger (minBound :: a) && x <= toInteger (maxBound :: a)@@ -606,8 +606,7 @@ LitNumWord16 -> i == 0 LitNumWord32 -> i == 0 LitNumWord64 -> i == 0- LitNumNatural -> i == 0- LitNumInteger -> False+ LitNumBigNat -> i == 0 isMinBound _ _ = False isMaxBound :: Platform -> Literal -> Bool@@ -623,8 +622,7 @@ LitNumWord16 -> i == toInteger (maxBound :: Word16) LitNumWord32 -> i == toInteger (maxBound :: Word32) LitNumWord64 -> i == toInteger (maxBound :: Word64)- LitNumNatural -> False- LitNumInteger -> False+ LitNumBigNat -> False isMaxBound _ _ = False inCharRange :: Char -> Bool@@ -645,7 +643,7 @@ isOneLit _ = False -- | Returns the 'Integer' contained in the 'Literal', for when that makes--- sense, i.e. for 'Char', 'Int', 'Word', 'LitInteger' and 'LitNatural'.+-- sense, i.e. for 'Char' and numbers. litValue :: Literal -> Integer litValue l = case isLitValue_maybe l of Just x -> x@@ -769,8 +767,7 @@ -- c.f. GHC.Core.Utils.exprIsTrivial litIsTrivial (LitString _) = False litIsTrivial (LitNumber nt _) = case nt of- LitNumInteger -> False- LitNumNatural -> False+ LitNumBigNat -> False LitNumInt -> True LitNumInt8 -> True LitNumInt16 -> True@@ -787,9 +784,8 @@ litIsDupable :: Platform -> Literal -> Bool -- c.f. GHC.Core.Utils.exprIsDupable litIsDupable platform x = case x of- (LitNumber nt i) -> case nt of- LitNumInteger -> platformInIntRange platform i- LitNumNatural -> platformInWordRange platform i+ LitNumber nt i -> case nt of+ LitNumBigNat -> i <= platformMaxWord platform * 8 -- arbitrary, reasonable LitNumInt -> True LitNumInt8 -> True LitNumInt16 -> True@@ -800,8 +796,8 @@ LitNumWord16 -> True LitNumWord32 -> True LitNumWord64 -> True- (LitString _) -> False- _ -> True+ LitString _ -> False+ _ -> True litFitsInChar :: Literal -> Bool litFitsInChar (LitNumber _ i) = i >= toInteger (ord minBound)@@ -810,8 +806,7 @@ litIsLifted :: Literal -> Bool litIsLifted (LitNumber nt _) = case nt of- LitNumInteger -> True- LitNumNatural -> True+ LitNumBigNat -> True LitNumInt -> False LitNumInt8 -> False LitNumInt16 -> False@@ -839,8 +834,7 @@ literalType (LitDouble _) = doublePrimTy literalType (LitLabel _ _ _) = addrPrimTy literalType (LitNumber lt _) = case lt of- LitNumInteger -> integerTy- LitNumNatural -> naturalTy+ LitNumBigNat -> byteArrayPrimTy LitNumInt -> intPrimTy LitNumInt8 -> int8PrimTy LitNumInt16 -> int16PrimTy@@ -889,10 +883,9 @@ pprLiteral _ (LitNullAddr) = text "__NULL" pprLiteral _ (LitFloat f) = float (fromRat f) <> primFloatSuffix pprLiteral _ (LitDouble d) = double (fromRat d) <> primDoubleSuffix-pprLiteral add_par (LitNumber nt i)+pprLiteral _ (LitNumber nt i) = case nt of- LitNumInteger -> pprIntegerVal add_par i- LitNumNatural -> pprIntegerVal add_par i+ LitNumBigNat -> integer i LitNumInt -> pprPrimInt i LitNumInt8 -> pprPrimInt8 i LitNumInt16 -> pprPrimInt16 i@@ -911,17 +904,12 @@ pprLiteral _ (LitRubbish rep) = text "RUBBISH" <> parens (ppr rep) -pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc--- See Note [Printing of literals in Core].-pprIntegerVal add_par i | i < 0 = add_par (integer i)- | otherwise = integer i- {- Note [Printing of literals in Core] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The function `add_par` is used to wrap parenthesis around negative integers-(`LitInteger`) and labels (`LitLabel`), if they occur in a context requiring-an atomic thing (for example function application).+The function `add_par` is used to wrap parenthesis around labels (`LitLabel`),+if they occur in a context requiring an atomic thing (for example function+application). Although not all Core literals would be valid Haskell, we are trying to stay as close as possible to Haskell syntax in the printing of Core, to make it@@ -949,7 +937,7 @@ LitWordN 1##N LitFloat -1.0# LitDouble -1.0##-LitInteger -1 (-1)+LitBigNat 1 LitLabel "__label" ... ("__label" ...) LitRubbish "RUBBISH[...]"
compiler/GHC/Types/Name/Env.hs view
@@ -16,13 +16,14 @@ -- ** Manipulating these environments mkNameEnv, mkNameEnvWith, emptyNameEnv, isEmptyNameEnv,- unitNameEnv, nameEnvElts,+ unitNameEnv, nonDetNameEnvElts, extendNameEnv_C, extendNameEnv_Acc, extendNameEnv, extendNameEnvList, extendNameEnvList_C, filterNameEnv, anyNameEnv, plusNameEnv, plusNameEnv_C, plusNameEnv_CD, plusNameEnv_CD2, alterNameEnv, lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv, elemNameEnv, mapNameEnv, disjointNameEnv,+ seqEltsNameEnv, DNameEnv, @@ -31,6 +32,7 @@ delFromDNameEnv, filterDNameEnv, mapDNameEnv, adjustDNameEnv, alterDNameEnv, extendDNameEnv,+ eltsDNameEnv, extendDNameEnv_C, -- ** Dependency analysis depAnal ) where@@ -97,7 +99,7 @@ isEmptyNameEnv :: NameEnv a -> Bool mkNameEnv :: [(Name,a)] -> NameEnv a mkNameEnvWith :: (a -> Name) -> [a] -> NameEnv a-nameEnvElts :: NameEnv a -> [a]+nonDetNameEnvElts :: NameEnv a -> [a] alterNameEnv :: (Maybe a-> Maybe a) -> NameEnv a -> Name -> NameEnv a extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a extendNameEnv_Acc :: (a->b->b) -> (a->b) -> NameEnv b -> Name -> a -> NameEnv b@@ -118,8 +120,9 @@ anyNameEnv :: (elt -> Bool) -> NameEnv elt -> Bool mapNameEnv :: (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2 disjointNameEnv :: NameEnv a -> NameEnv a -> Bool+seqEltsNameEnv :: (elt -> ()) -> NameEnv elt -> () -nameEnvElts x = eltsUFM x+nonDetNameEnvElts x = nonDetEltsUFM x emptyNameEnv = emptyUFM isEmptyNameEnv = isNullUFM unitNameEnv x y = unitUFM x y@@ -144,6 +147,7 @@ filterNameEnv x y = filterUFM x y anyNameEnv f x = foldUFM ((||) . f) False x disjointNameEnv x y = disjointUFM x y+seqEltsNameEnv seqElt x = seqEltsUFM seqElt x lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupNameEnv env n) @@ -176,3 +180,9 @@ extendDNameEnv :: DNameEnv a -> Name -> a -> DNameEnv a extendDNameEnv = addToUDFM++extendDNameEnv_C :: (a -> a -> a) -> DNameEnv a -> Name -> a -> DNameEnv a+extendDNameEnv_C = addToUDFM_C++eltsDNameEnv :: DNameEnv a -> [a]+eltsDNameEnv = eltsUDFM
compiler/GHC/Types/Name/Occurrence.hs view
@@ -81,7 +81,7 @@ -- * The 'OccEnv' type OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv, lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv,- occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C,+ nonDetOccEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C, extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv, alterOccEnv, pprOccEnv, @@ -401,7 +401,7 @@ mkOccEnv_C :: (a -> a -> a) -> [(OccName,a)] -> OccEnv a elemOccEnv :: OccName -> OccEnv a -> Bool foldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b-occEnvElts :: OccEnv a -> [a]+nonDetOccEnvElts :: OccEnv a -> [a] extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a extendOccEnv_Acc :: (a->b->b) -> (a->b) -> OccEnv b -> OccName -> a -> OccEnv b plusOccEnv :: OccEnv a -> OccEnv a -> OccEnv a@@ -420,7 +420,7 @@ mkOccEnv l = A $ listToUFM l elemOccEnv x (A y) = elemUFM x y foldOccEnv a b (A c) = foldUFM a b c-occEnvElts (A x) = eltsUFM x+nonDetOccEnvElts (A x) = nonDetEltsUFM x plusOccEnv (A x) (A y) = A $ plusUFM x y plusOccEnv_C f (A x) (A y) = A $ plusUFM_C f x y extendOccEnv_C f (A x) y z = A $ addToUFM_C f x y z
compiler/GHC/Types/Name/Reader.hs view
@@ -428,7 +428,7 @@ Orig {} -> False localRdrEnvElts :: LocalRdrEnv -> [Name]-localRdrEnvElts (LRE { lre_env = env }) = occEnvElts env+localRdrEnvElts (LRE { lre_env = env }) = nonDetOccEnvElts env inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool -- This is the point of the NameSet@@ -760,7 +760,7 @@ -- uniqueness assumption. gresToAvailInfo :: [GlobalRdrElt] -> [AvailInfo] gresToAvailInfo gres- = nameEnvElts avail_env+ = nonDetNameEnvElts avail_env where avail_env :: NameEnv AvailInfo -- Keyed by the parent (avail_env, _) = foldl' add (emptyNameEnv, emptyNameSet) gres@@ -818,7 +818,7 @@ pprGlobalRdrEnv locals_only env = vcat [ text "GlobalRdrEnv" <+> ppWhen locals_only (text "(locals only)") <+> lbrace- , nest 2 (vcat [ pp (remove_locals gre_list) | gre_list <- occEnvElts env ]+ , nest 2 (vcat [ pp (remove_locals gre_list) | gre_list <- nonDetOccEnvElts env ] <+> rbrace) ] where remove_locals gres | locals_only = filter isLocalGRE gres
compiler/GHC/Types/TypeEnv.hs view
@@ -49,7 +49,7 @@ lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing emptyTypeEnv = emptyNameEnv-typeEnvElts env = nameEnvElts env+typeEnvElts env = nonDetNameEnvElts env typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env] typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env] typeEnvIds env = [id | AnId id <- typeEnvElts env]
compiler/GHC/Types/Unique/FM.hs view
@@ -63,7 +63,7 @@ intersectUFM_C, disjointUFM, equalKeysUFM,- nonDetStrictFoldUFM, foldUFM, nonDetStrictFoldUFM_Directly,+ nonDetStrictFoldUFM, foldUFM, nonDetStrictFoldUFM_DirectlyM, anyUFM, allUFM, seqEltsUFM, mapUFM, mapUFM_Directly, elemUFM, elemUFM_Directly,@@ -72,7 +72,7 @@ isNullUFM, lookupUFM, lookupUFM_Directly, lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,- nonDetEltsUFM, eltsUFM, nonDetKeysUFM,+ nonDetEltsUFM, nonDetKeysUFM, ufmToSet_Directly, nonDetUFMToList, ufmToIntMap, unsafeIntMapToUFM, unsafeCastUFMKey,@@ -369,9 +369,6 @@ lookupWithDefaultUFM_Directly :: UniqFM key elt -> elt -> Unique -> elt lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m -eltsUFM :: UniqFM key elt -> [elt]-eltsUFM (UFM m) = M.elems m- ufmToSet_Directly :: UniqFM key elt -> S.IntSet ufmToSet_Directly (UFM m) = M.keysSet m @@ -381,8 +378,8 @@ allUFM :: (elt -> Bool) -> UniqFM key elt -> Bool allUFM p (UFM m) = M.foldr ((&&) . p) True m -seqEltsUFM :: ([elt] -> ()) -> UniqFM key elt -> ()-seqEltsUFM seqList = seqList . nonDetEltsUFM+seqEltsUFM :: (elt -> ()) -> UniqFM key elt -> ()+seqEltsUFM seqElt = foldUFM (\v rest -> seqElt v `seq` rest) () -- It's OK to use nonDetEltsUFM here because the type guarantees that -- the only interesting thing this function can do is to force the -- elements.@@ -405,11 +402,16 @@ nonDetStrictFoldUFM :: (elt -> a -> a) -> a -> UniqFM key elt -> a nonDetStrictFoldUFM k z (UFM m) = M.foldl' (flip k) z m +-- | In essence foldM -- See Note [Deterministic UniqFM] to learn about nondeterminism. -- If you use this please provide a justification why it doesn't introduce -- nondeterminism.-nonDetStrictFoldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM key elt -> a-nonDetStrictFoldUFM_Directly k z (UFM m) = M.foldlWithKey' (\z' i x -> k (getUnique i) x z') z m+{-# INLINE nonDetStrictFoldUFM_DirectlyM #-} -- Allow specialization+nonDetStrictFoldUFM_DirectlyM :: (Monad m) => (Unique -> b -> elt -> m b) -> b -> UniqFM key elt -> m b+nonDetStrictFoldUFM_DirectlyM f z0 (UFM xs) = M.foldrWithKey c return xs z0+ -- See Note [List fusion and continuations in 'c']+ where c u x k z = f (getUnique u) z x >>= k+ {-# INLINE c #-} -- See Note [Deterministic UniqFM] to learn about nondeterminism. -- If you use this please provide a justification why it doesn't introduce
compiler/GHC/Types/Unique/Map.hs view
@@ -72,7 +72,7 @@ ppr (UniqMap m) = brackets $ fsep $ punctuate comma $ [ ppr k <+> text "->" <+> ppr v- | (k, v) <- eltsUFM m ]+ | (k, v) <- nonDetEltsUFM m ] liftC :: (a -> a -> a) -> (k, a) -> (k, a) -> (k, a) liftC f (_, v) (k', v') = (k', f v v')
compiler/GHC/Types/Unique/Supply.hs view
@@ -254,7 +254,7 @@ uniqFromMask !mask = do { uqNum <- genSym ; return $! mkUnique mask uqNum }-+{-# NOINLINE uniqFromMask #-} -- We'll unbox everything, but we don't want to inline it splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply) -- ^ Build two 'UniqSupply' from a single one, each of which
compiler/GHC/Types/Var.hs-boot view
@@ -18,4 +18,5 @@ type TyVar = Var type Id = Var type TyCoVar = Id+type TcTyVar = Var type InvisTVBinder = VarBndr TyVar Specificity
compiler/GHC/Unit/Home/ModInfo.hs view
@@ -32,7 +32,7 @@ import GHC.Types.Unique.DFM import GHC.Utils.Outputable-import Data.List+import Data.List (sortOn) import Data.Ord -- | Information about modules in the package being compiled
compiler/GHC/Unit/Module/Deps.hs view
@@ -1,8 +1,20 @@ -- | Dependencies and Usage of a module module GHC.Unit.Module.Deps- ( Dependencies (..)- , Usage (..)+ ( Dependencies+ , mkDependencies , noDependencies+ , dep_direct_mods+ , dep_direct_pkgs+ , dep_sig_mods+ , dep_trusted_pkgs+ , dep_orphs+ , dep_finsts+ , dep_boot_mods+ , dep_orphs_update+ , dep_finsts_update+ , pprDeps+ , Usage (..)+ , ImportAvails (..) ) where @@ -10,12 +22,19 @@ import GHC.Types.SafeHaskell import GHC.Types.Name+import GHC.Types.Unique.FM+ import GHC.Unit.Module.Name+import GHC.Unit.Module.Imported import GHC.Unit.Module+import GHC.Unit.Home+import GHC.Unit.State import GHC.Utils.Fingerprint import GHC.Utils.Binary+import GHC.Utils.Outputable +import Data.List (sortBy, sort, partition) import Data.Set (Set) import qualified Data.Set as Set @@ -26,6 +45,8 @@ -- -- Invariant: none of the lists contain duplicates. --+-- Invariant: lists are ordered canonically (e.g. using stableModuleCmp)+-- -- See Note [Transitive Information in Dependencies] data Dependencies = Deps { dep_direct_mods :: Set ModuleNameWithIsBoot@@ -34,9 +55,10 @@ , dep_direct_pkgs :: Set UnitId -- ^ All packages directly imported by this module -- I.e. packages to which this module's direct imports belong.- -- + ------------------------------------ -- Transitive information below here+ , dep_sig_mods :: ![ModuleName] -- ^ Transitive closure of hsig files in the home package @@ -74,6 +96,71 @@ -- Equality used only for old/new comparison in GHC.Iface.Recomp.addFingerprints -- See 'GHC.Tc.Utils.ImportAvails' for details on dependencies. ++-- | Extract information from the rename and typecheck phases to produce+-- a dependencies information for the module being compiled.+--+-- The fourth argument is a list of plugin modules.+mkDependencies :: HomeUnit -> Module -> ImportAvails -> [Module] -> Dependencies+mkDependencies home_unit mod imports plugin_mods =+ let (home_plugins, external_plugins) = partition (isHomeUnit home_unit . moduleUnit) plugin_mods+ plugin_units = Set.fromList (map (toUnitId . moduleUnit) external_plugins)+ all_direct_mods = foldr (\mn m -> addToUFM m mn (GWIB mn NotBoot))+ (imp_direct_dep_mods imports)+ (map moduleName home_plugins)++ modDepsElts = Set.fromList . nonDetEltsUFM+ -- It's OK to use nonDetEltsUFM here because sorting by module names+ -- restores determinism++ direct_mods = modDepsElts (delFromUFM all_direct_mods (moduleName mod))+ -- M.hi-boot can be in the imp_dep_mods, but we must remove+ -- it before recording the modules on which this one depends!+ -- (We want to retain M.hi-boot in imp_dep_mods so that+ -- loadHiBootInterface can see if M's direct imports depend+ -- on M.hi-boot, and hence that we should do the hi-boot consistency+ -- check.)++ dep_orphs = filter (/= mod) (imp_orphs imports)+ -- We must also remove self-references from imp_orphs. See+ -- Note [Module self-dependency]++ direct_pkgs = foldr Set.insert (imp_dep_direct_pkgs imports) plugin_units++ -- Set the packages required to be Safe according to Safe Haskell.+ -- See Note [Tracking Trust Transitively] in GHC.Rename.Names+ trust_pkgs = imp_trust_pkgs imports++ -- If there's a non-boot import, then it shadows the boot import+ -- coming from the dependencies+ source_mods = modDepsElts (imp_boot_mods imports)++ sig_mods = filter (/= (moduleName mod)) $ imp_sig_mods imports++ in Deps { dep_direct_mods = direct_mods+ , dep_direct_pkgs = direct_pkgs+ , dep_sig_mods = sort sig_mods+ , dep_trusted_pkgs = trust_pkgs+ , dep_boot_mods = source_mods+ , dep_orphs = sortBy stableModuleCmp dep_orphs+ , dep_finsts = sortBy stableModuleCmp (imp_finsts imports)+ -- sort to get into canonical order+ -- NB. remember to use lexicographic ordering+ }++-- | Update module dependencies containing orphans (used by Backpack)+dep_orphs_update :: Monad m => Dependencies -> ([Module] -> m [Module]) -> m Dependencies+dep_orphs_update deps f = do+ r <- f (dep_orphs deps)+ pure (deps { dep_orphs = sortBy stableModuleCmp r })++-- | Update module dependencies containing family instances (used by Backpack)+dep_finsts_update :: Monad m => Dependencies -> ([Module] -> m [Module]) -> m Dependencies+dep_finsts_update deps f = do+ r <- f (dep_finsts deps)+ pure (deps { dep_finsts = sortBy stableModuleCmp r })++ instance Binary Dependencies where put_ bh deps = do put_ bh (dep_direct_mods deps) put_ bh (dep_direct_pkgs deps)@@ -109,6 +196,32 @@ , dep_finsts = [] } +-- | Pretty-print unit dependencies+pprDeps :: UnitState -> Dependencies -> SDoc+pprDeps unit_state (Deps { dep_direct_mods = dmods+ , dep_boot_mods = bmods+ , dep_orphs = orphs+ , dep_direct_pkgs = pkgs+ , dep_trusted_pkgs = tps+ , dep_finsts = finsts+ })+ = pprWithUnitState unit_state $+ vcat [text "direct module dependencies:" <+> ppr_set ppr_mod dmods,+ text "boot module dependencies:" <+> ppr_set ppr bmods,+ text "direct package dependencies:" <+> ppr_set ppr pkgs,+ if null tps+ then empty+ else text "trusted package dependencies:" <+> ppr_set ppr tps,+ text "orphans:" <+> fsep (map ppr orphs),+ text "family instance modules:" <+> fsep (map ppr finsts)+ ]+ where+ ppr_mod (GWIB mod IsBoot) = ppr mod <+> text "[boot]"+ ppr_mod (GWIB mod NotBoot) = ppr mod++ ppr_set :: Outputable a => (a -> SDoc) -> Set a -> SDoc+ ppr_set w = fsep . fmap w . Set.toAscList+ -- | Records modules for which changes may force recompilation of this module -- See wiki: https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance --@@ -327,3 +440,67 @@ No: if I need to load the interface for module X from package P I always look for p:X.hi. -}++-- | 'ImportAvails' summarises what was imported from where, irrespective of+-- whether the imported things are actually used or not. It is used:+--+-- * when processing the export list,+--+-- * when constructing usage info for the interface file,+--+-- * to identify the list of directly imported modules for initialisation+-- purposes and for optimised overlap checking of family instances,+--+-- * when figuring out what things are really unused+--+data ImportAvails+ = ImportAvails {+ imp_mods :: ImportedMods,+ -- = ModuleEnv [ImportedModsVal],+ -- ^ Domain is all directly-imported modules+ --+ -- See the documentation on ImportedModsVal in+ -- "GHC.Unit.Module.Imported" for the meaning of the fields.+ --+ -- We need a full ModuleEnv rather than a ModuleNameEnv here,+ -- because we might be importing modules of the same name from+ -- different packages. (currently not the case, but might be in the+ -- future).++ imp_direct_dep_mods :: ModuleNameEnv ModuleNameWithIsBoot,+ -- ^ Home-package modules directly imported by the module being compiled.++ imp_dep_direct_pkgs :: Set UnitId,+ -- ^ Packages directly needed by the module being compiled++ imp_trust_own_pkg :: Bool,+ -- ^ Do we require that our own package is trusted?+ -- This is to handle efficiently the case where a Safe module imports+ -- a Trustworthy module that resides in the same package as it.+ -- See Note [Trust Own Package] in "GHC.Rename.Names"++ -- Transitive information below here++ imp_trust_pkgs :: Set UnitId,+ -- ^ This records the+ -- packages the current module needs to trust for Safe Haskell+ -- compilation to succeed. A package is required to be trusted if+ -- we are dependent on a trustworthy module in that package.+ -- See Note [Tracking Trust Transitively] in "GHC.Rename.Names"++ imp_boot_mods :: ModuleNameEnv ModuleNameWithIsBoot,+ -- ^ Domain is all modules which have hs-boot files, and whether+ -- we should import the boot version of interface file. Only used+ -- in one-shot mode to populate eps_is_boot.++ imp_sig_mods :: [ModuleName],+ -- ^ Signature modules below this one++ imp_orphs :: [Module],+ -- ^ Orphan modules below us in the import tree (and maybe including+ -- us for imported modules)++ imp_finsts :: [Module]+ -- ^ Family instance modules below us in the import tree (and maybe+ -- including us for imported modules)+ }
compiler/GHC/Unit/Module/ModSummary.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-} -- | A ModSummary is a node in the compilation manager's dependency graph -- (ModuleGraph)@@ -10,6 +11,7 @@ , ms_installed_mod , ms_mod_name , ms_imps+ , ms_plugin_imps , ms_mnwib , ms_home_srcimps , ms_home_imps@@ -114,11 +116,11 @@ -- | Textual imports, plus plugin imports but not SOURCE imports. ms_imps :: ModSummary -> [(Maybe FastString, Located ModuleName)]-ms_imps ms =- ms_textual_imps ms ++- map mk_additional_import (dynFlagDependencies (ms_hspp_opts ms))- where- mk_additional_import mod_nm = (Nothing, noLoc mod_nm)+ms_imps ms = ms_textual_imps ms ++ ms_plugin_imps ms++-- | Plugin imports+ms_plugin_imps :: ModSummary -> [(Maybe FastString, Located ModuleName)]+ms_plugin_imps ms = map ((Nothing,) . noLoc) (pluginModNames (ms_hspp_opts ms)) home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName] home_imps imps = [ lmodname | (mb_pkg, lmodname) <- imps,
compiler/Language/Haskell/Syntax/Expr.hs view
@@ -40,7 +40,6 @@ import GHC.Types.Fixity import GHC.Types.SourceText import GHC.Types.SrcLoc-import GHC.Types.Tickish import GHC.Unit.Module (ModuleName) import GHC.Utils.Outputable import GHC.Utils.Panic@@ -638,20 +637,6 @@ (LHsExpr p) -- Body ---------------------------------------- -- Haskell program coverage (Hpc) Support-- | HsTick- (XTick p)- CoreTickish- (LHsExpr p) -- sub-expression-- | HsBinTick- (XBinTick p)- Int -- module-local tick number for True- Int -- module-local tick number for False- (LHsExpr p) -- sub-expression-- --------------------------------------- -- Expressions annotated with pragmas, written as {-# ... #-} | HsPragE (XPragE p) (HsPragE p) (LHsExpr p) @@ -1067,7 +1052,7 @@ data Match p body = Match { m_ext :: XCMatch p body,- m_ctxt :: HsMatchContext (NoGhcTc p),+ m_ctxt :: HsMatchContext p, -- See note [m_ctxt in Match] m_pats :: [LPat p], -- The patterns m_grhss :: (GRHSs p body)
ghc-lib-parser.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-parser-version: 0.20210901+version: 0.20211001 license: BSD3 license-file: LICENSE category: Development@@ -343,6 +343,7 @@ GHC.Tc.Types.Constraint GHC.Tc.Types.Evidence GHC.Tc.Types.Origin+ GHC.Tc.Types.Rank GHC.Tc.Utils.TcType GHC.Types.Annotations GHC.Types.Avail
ghc-lib/stage0/compiler/build/GHC/Parser.hs view
@@ -407,8 +407,8 @@ happyOut57 :: (HappyAbsSyn ) -> HappyWrap57 happyOut57 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut57 #-}-newtype HappyWrap58 = HappyWrap58 ([TrailingAnn])-happyIn58 :: ([TrailingAnn]) -> (HappyAbsSyn )+newtype HappyWrap58 = HappyWrap58 (Located [TrailingAnn])+happyIn58 :: (Located [TrailingAnn]) -> (HappyAbsSyn ) happyIn58 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap58 x) {-# INLINE happyIn58 #-} happyOut58 :: (HappyAbsSyn ) -> HappyWrap58@@ -925,8 +925,8 @@ happyOut129 :: (HappyAbsSyn ) -> HappyWrap129 happyOut129 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut129 #-}-newtype HappyWrap130 = HappyWrap130 (Maybe (Located (HsLocalBinds GhcPs)))-happyIn130 :: (Maybe (Located (HsLocalBinds GhcPs))) -> (HappyAbsSyn )+newtype HappyWrap130 = HappyWrap130 (Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments )))+happyIn130 :: (Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments ))) -> (HappyAbsSyn ) happyIn130 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap130 x) {-# INLINE happyIn130 #-} happyOut130 :: (HappyAbsSyn ) -> HappyWrap130@@ -4174,7 +4174,7 @@ = case happyOut58 happy_x_1 of { (HappyWrap58 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> happyIn58- (if isZeroWidthSpan (gl happy_var_2) then happy_var_1 else (AddSemiAnn (glAA happy_var_2) : happy_var_1)+ (sLL happy_var_1 happy_var_2 $ if isZeroWidthSpan (gl happy_var_2) then (unLoc happy_var_1) else (AddSemiAnn (glAA happy_var_2) : (unLoc happy_var_1)) )}} happyReduce_112 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -4182,7 +4182,7 @@ happyReduction_112 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> happyIn58- (msemi happy_var_1+ (sL1 happy_var_1 $ msemi happy_var_1 )} happyReduce_113 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -4220,7 +4220,7 @@ = happyThen ((case happyOut61 happy_x_1 of { (HappyWrap61 happy_var_1) -> case happyOut62 happy_x_2 of { (HappyWrap62 happy_var_2) -> case happyOut58 happy_x_3 of { (HappyWrap58 happy_var_3) -> - ( do { i <- amsA happy_var_2 happy_var_3+ ( do { i <- amsAl happy_var_2 (comb2 (reLoc happy_var_2) happy_var_3) (unLoc happy_var_3) ; return (i : happy_var_1)})}}}) ) (\r -> happyReturn (happyIn61 r)) @@ -4483,7 +4483,7 @@ = happyThen ((case happyOut74 happy_x_1 of { (HappyWrap74 happy_var_1) -> case happyOut78 happy_x_2 of { (HappyWrap78 happy_var_2) -> case happyOut58 happy_x_3 of { (HappyWrap58 happy_var_3) -> - ( do { t <- amsA happy_var_2 happy_var_3+ ( do { t <- amsAl happy_var_2 (comb2 (reLoc happy_var_2) happy_var_3) (unLoc happy_var_3) ; return (happy_var_1 `snocOL` t) })}}}) ) (\r -> happyReturn (happyIn74 r)) @@ -4512,7 +4512,7 @@ = happyThen ((case happyOut76 happy_x_1 of { (HappyWrap76 happy_var_1) -> case happyOut77 happy_x_2 of { (HappyWrap77 happy_var_2) -> case happyOut58 happy_x_3 of { (HappyWrap58 happy_var_3) -> - ( do { t <- amsA happy_var_2 happy_var_3+ ( do { t <- amsAl happy_var_2 (comb2 (reLoc happy_var_2) happy_var_3) (unLoc happy_var_3) ; return (happy_var_1 `snocOL` t) })}}}) ) (\r -> happyReturn (happyIn76 r)) @@ -6204,14 +6204,16 @@ ) (\r -> happyReturn (happyIn129 r)) happyReduce_291 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )-happyReduce_291 = happySpecReduce_2 114# happyReduction_291-happyReduction_291 happy_x_2- happy_x_1- = case happyOutTok happy_x_1 of { happy_var_1 -> +happyReduce_291 = happyMonadReduce 2# 114# happyReduction_291+happyReduction_291 (happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest) tk+ = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut129 happy_x_2 of { (HappyWrap129 happy_var_2) -> - happyIn130- (Just (sLL happy_var_1 happy_var_2 (annBinds (mj AnnWhere happy_var_1) (unLoc happy_var_2)))- )}}+ ( do { r <- acs (\cs ->+ (sLL happy_var_1 happy_var_2 (annBinds (mj AnnWhere happy_var_1) cs (unLoc happy_var_2))))+ ; return $ Just r})}})+ ) (\r -> happyReturn (happyIn130 r)) happyReduce_292 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_292 = happySpecReduce_0 114# happyReduction_292@@ -8138,22 +8140,24 @@ case happyOut206 happy_x_2 of { (HappyWrap206 happy_var_2) -> case happyOut130 happy_x_3 of { (HappyWrap130 happy_var_3) -> ( runPV (unECP happy_var_2) >>= \ happy_var_2 ->- do { let loc = (comb3 happy_var_1 (reLoc happy_var_2) (adaptWhereBinds happy_var_3))+ do { let L l (bs, csw) = adaptWhereBinds happy_var_3+ ; let loc = (comb3 happy_var_1 (reLoc happy_var_2) (L l bs)) ; acs (\cs ->- sL loc (GRHSs NoExtField (unguardedRHS (EpAnn (anc $ rs loc) (GrhsAnn Nothing (mj AnnEqual happy_var_1)) cs) loc happy_var_2)- (unLoc $ (adaptWhereBinds happy_var_3)))) })}}})+ sL loc (GRHSs csw (unguardedRHS (EpAnn (anc $ rs loc) (GrhsAnn Nothing (mj AnnEqual happy_var_1)) cs) loc happy_var_2)+ bs)) })}}}) ) (\r -> happyReturn (happyIn199 r)) happyReduce_468 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )-happyReduce_468 = happySpecReduce_2 183# happyReduction_468-happyReduction_468 happy_x_2- happy_x_1- = case happyOut200 happy_x_1 of { (HappyWrap200 happy_var_1) -> +happyReduce_468 = happyMonadReduce 2# 183# happyReduction_468+happyReduction_468 (happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest) tk+ = happyThen ((case happyOut200 happy_x_1 of { (HappyWrap200 happy_var_1) -> case happyOut130 happy_x_2 of { (HappyWrap130 happy_var_2) -> - happyIn199- (sL (comb2 happy_var_1 (adaptWhereBinds happy_var_2))- (GRHSs noExtField (reverse (unLoc happy_var_1)) (unLoc $ (adaptWhereBinds happy_var_2)))- )}}+ ( do { let {L l (bs, csw) = adaptWhereBinds happy_var_2}+ ; acs (\cs -> sL (comb2 happy_var_1 (L l bs))+ (GRHSs (cs Semi.<> csw) (reverse (unLoc happy_var_1)) bs)) })}})+ ) (\r -> happyReturn (happyIn199 r)) happyReduce_469 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_469 = happySpecReduce_2 184# happyReduction_469@@ -9986,7 +9990,8 @@ case happyOut130 happy_x_2 of { (HappyWrap130 happy_var_2) -> happyIn240 (happy_var_1 >>= \alt ->- return $ sLL alt (adaptWhereBinds happy_var_2) (GRHSs noExtField (unLoc alt) (unLoc $ adaptWhereBinds happy_var_2))+ do { let {L l (bs, csw) = adaptWhereBinds happy_var_2}+ ; acs (\cs -> sLL alt (L l bs) (GRHSs (cs Semi.<> csw) (unLoc alt) bs)) } )}} happyReduce_615 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -12516,6 +12521,11 @@ cs <- getCommentsFor (locA l) return (L (addAnnsA l bs cs) a) +amsAl :: MonadP m => LocatedA a -> SrcSpan -> [TrailingAnn] -> m (LocatedA a)+amsAl (L l a) loc bs = do+ cs <- getCommentsFor loc+ return (L (addAnnsA l bs cs) a)+ amsrc :: MonadP m => Located a -> AnnContext -> m (LocatedC a) amsrc a@(L l _) bs = do cs <- getCommentsFor l@@ -12686,9 +12696,10 @@ -- We need a location for the where binds, when computing the SrcSpan -- for the AST element using them. Where there is a span, we return -- it, else noLoc, which is ignored in the comb2 call.-adaptWhereBinds :: Maybe (Located (HsLocalBinds GhcPs)) -> Located (HsLocalBinds GhcPs)-adaptWhereBinds Nothing = noLoc (EmptyLocalBinds noExtField)-adaptWhereBinds (Just b) = b+adaptWhereBinds :: Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments))+ -> Located (HsLocalBinds GhcPs, EpAnnComments)+adaptWhereBinds Nothing = noLoc (EmptyLocalBinds noExtField, emptyComments)+adaptWhereBinds (Just (L l (b, mc))) = L l (b, maybe emptyComments id mc) {-# LINE 1 "templates/GenericTemplate.hs" #-} -- $Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp $
ghc-lib/stage0/compiler/build/primop-docs.hs-incl view
@@ -319,6 +319,7 @@ , ("traceBinaryEvent#"," Emits an event via the RTS tracing framework. The contents\n of the event is the binary object passed as the first argument with\n the given length passed as the second argument. The event will be\n emitted to the @.eventlog@ file. ") , ("traceMarker#"," Emits a marker event via the RTS tracing framework. The contents\n of the event is the zero-terminated byte string passed as the first\n argument. The event will be emitted either to the @.eventlog@ file,\n or to stderr, depending on the runtime RTS flags. ") , ("setThreadAllocationCounter#"," Sets the allocation counter for the current thread to the given value. ")+ , ("StackSnapshot#"," Haskell representation of a @StgStack*@ that was created (cloned)\n with a function in @GHC.Stack.CloneStack@. Please check the\n documentation in this module for more detailed explanations. ") , ("coerce"," The function @coerce@ allows you to safely convert between values of\n types that have the same representation with no run-time overhead. In the\n simplest case you can use it instead of a newtype constructor, to go from\n the newtype's concrete type to the abstract type. But it also works in\n more complicated settings, e.g. converting a list of newtypes to a list of\n concrete types.\n\n This function is representation-polymorphic, but the\n @RuntimeRep@ type argument is marked as @Inferred@, meaning\n that it is not available for visible type application. This means\n the typechecker will accept @coerce @Int @Age 42@.\n ") , ("broadcastInt8X16#"," Broadcast a scalar to all elements of a vector. ") , ("broadcastInt16X8#"," Broadcast a scalar to all elements of a vector. ")
ghc-lib/stage0/lib/ghcautoconf.h view
@@ -176,9 +176,6 @@ /* Define to 1 if you have the `dl' library (-ldl). */ #define HAVE_LIBDL 1 -/* Define to 1 if you have libffi. */-/* #undef HAVE_LIBFFI */- /* Define to 1 if you have the `iberty' library (-liberty). */ /* #undef HAVE_LIBIBERTY */ @@ -286,6 +283,9 @@ /* Define to 1 if you have the `sysconf' function. */ #define HAVE_SYSCONF 1++/* Define to 1 if you have libffi. */+/* #undef HAVE_SYSTEM_LIBFFI */ /* Define to 1 if you have the <sys/cpuset.h> header file. */ /* #undef HAVE_SYS_CPUSET_H */
ghc-lib/stage0/lib/settings view
@@ -1,8 +1,8 @@ [("GCC extra via C opts", "") ,("C compiler command", "cc")-,("C compiler flags", "")-,("C++ compiler flags", "")-,("C compiler link flags", "")+,("C compiler flags", "--target=x86_64-apple-darwin ")+,("C++ compiler flags", "--target=x86_64-apple-darwin ")+,("C compiler link flags", "--target=x86_64-apple-darwin ") ,("C compiler supports -no-pie", "NO") ,("Haskell CPP command", "cc") ,("Haskell CPP flags", "-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs")@@ -35,6 +35,7 @@ ,("target has .ident directive", "YES") ,("target has subsections via symbols", "YES") ,("target has RTS linker", "YES")+,("target has libm", "YES") ,("Unregisterised", "NO") ,("LLVM target", "x86_64-apple-darwin") ,("LLVM llc command", "llc")
ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs view
@@ -3,19 +3,19 @@ import Prelude -- See Note [Why do we import Prelude here?] cProjectGitCommitId :: String-cProjectGitCommitId = "922c6bc8dd8d089cfe4b90ec2120cb48959ba2b5"+cProjectGitCommitId = "ef92a0095cee1f623fba1c285c1836e80bf16223" cProjectVersion :: String-cProjectVersion = "9.3.20210828"+cProjectVersion = "9.3.20210930" cProjectVersionInt :: String cProjectVersionInt = "903" cProjectPatchLevel :: String-cProjectPatchLevel = "20210828"+cProjectPatchLevel = "20210930" cProjectPatchLevel1 :: String-cProjectPatchLevel1 = "20210828"+cProjectPatchLevel1 = "20210930" cProjectPatchLevel2 :: String cProjectPatchLevel2 = ""
libraries/ghc-boot/GHC/Unit/Database.hs view
@@ -87,6 +87,10 @@ import Control.Exception as Exception import Control.Monad (when) import System.FilePath as FilePath+#if !defined(mingw32_HOST_OS)+import System.Posix.Files+import GHC.IO.Exception (ioe_type, IOErrorType(NoSuchThing))+#endif import System.IO import System.IO.Error import GHC.IO.Exception (IOErrorType(InappropriateType))@@ -503,6 +507,26 @@ -- Copied from Cabal's Distribution.Simple.Utils. writeFileAtomic :: FilePath -> BS.Lazy.ByteString -> IO () writeFileAtomic targetPath content = do+ -- Figure out how to update the file mode after we create the temporary file+ let no_update _path = return ()+#if !defined(mingw32_HOST_OS)+ let on_error ioe =+ -- If the file doesn't yet exist then just use the default owner and+ -- mode.+ case ioe_type ioe of+ NoSuchThing -> return no_update+ _ -> ioError ioe+ let handleIO :: (IOException -> IO a) -> IO a -> IO a+ handleIO = flip catch+ set_metadata <- handleIO on_error $ do+ status <- getFileStatus targetPath+ return $ \path -> do+ setFileMode path (fileMode status)+ setOwnerAndGroup path (fileOwner status) (fileGroup status)+#else+ let set_metadata = no_update+#endif+ let (targetDir, targetFile) = splitFileName targetPath Exception.bracketOnError (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp")@@ -510,6 +534,7 @@ (\(tmpPath, handle) -> do BS.Lazy.hPut handle content hClose handle+ set_metadata tmpPath renameFile tmpPath targetPath) instance Binary DbUnitInfo where
libraries/ghci/GHCi/Message.hs view
@@ -462,7 +462,7 @@ #define MIN_VERSION_ghc_heap(major1,major2,minor) (\ (major1) < 9 || \ (major1) == 9 && (major2) < 3 || \- (major1) == 9 && (major2) == 3 && (minor) <= 20210828)+ (major1) == 9 && (major2) == 3 && (minor) <= 20210930) #endif /* MIN_VERSION_ghc_heap */ #if MIN_VERSION_ghc_heap(8,11,0) instance Binary Heap.StgTSOProfInfo