diff --git a/compiler/GHC/Core/FVs.hs b/compiler/GHC/Core/FVs.hs --- a/compiler/GHC/Core/FVs.hs +++ b/compiler/GHC/Core/FVs.hs @@ -625,7 +625,14 @@ dVarTypeTyCoVars var = fvDVarSet $ varTypeTyCoFVs var varTypeTyCoFVs :: Var -> FV -varTypeTyCoFVs var = tyCoFVsOfType (varType var) +-- Find the free variables of a binder. +-- In the case of ids, don't forget the multiplicity field! +varTypeTyCoFVs var + = tyCoFVsOfType (varType var) `unionFV` mult_fvs + where + mult_fvs = case varMultMaybe var of + Just mult -> tyCoFVsOfType mult + Nothing -> emptyFV idFreeVars :: Id -> VarSet idFreeVars id = ASSERT( isId id) fvVarSet $ idFVs id diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -776,12 +776,12 @@ andArityType (AT (os1:oss1) div1) (AT (os2:oss2) div2) | AT oss' div' <- andArityType (AT oss1 div1) (AT oss2 div2) = AT ((os1 `bestOneShot` os2) : oss') div' -- See Note [Combining case branches] -andArityType (AT [] div1) at2 +andArityType at1@(AT [] div1) at2 | isDeadEndDiv div1 = at2 -- Note [ABot branches: max arity wins] - | otherwise = takeWhileOneShot at2 -- See Note [Combining case branches] -andArityType at1 (AT [] div2) + | otherwise = at1 -- See Note [Combining case branches] +andArityType at1 at2@(AT [] div2) | isDeadEndDiv div2 = at1 -- Note [ABot branches: max arity wins] - | otherwise = takeWhileOneShot at1 -- See Note [Combining case branches] + | otherwise = at2 -- See Note [Combining case branches] {- Note [ABot branches: max arity wins] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -794,24 +794,13 @@ Note [Combining case branches] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - go = \x. let z = go e0 - go2 = \x. case x of - True -> z - False -> \s(one-shot). e1 - in go2 x -We *really* want to respect the one-shot annotation provided by the -user and eta-expand go and go2. -When combining the branches of the case we have - T `andAT` \1.T -and we want to get \1.T. -But if the inner lambda wasn't one-shot (\?.T) we don't want to do this. -(We need a usage analysis to justify that.) -So we combine the best of the two branches, on the (slightly dodgy) -basis that if we know one branch is one-shot, then they all must be. -Surprisingly, this means that the one-shot arity type is effectively the top -element of the lattice. +Unless we can conclude that **all** branches are safe to eta-expand then we +must pessimisticaly conclude that we can't eta-expand. See #21694 for where this +went wrong. +We can do better in the long run, but for the 9.4/9.2 branches we choose to simply +ignore oneshot annotations for the time being. + Note [Arity trimming] ~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -84,6 +84,7 @@ import GHC.Types.Name import GHC.Types.Literal import GHC.Types.Tickish +import GHC.Types.Demand ( isDeadEndAppSig ) import GHC.Core.DataCon import GHC.Builtin.PrimOps import GHC.Types.Id @@ -1116,7 +1117,7 @@ | otherwise = go 0 e where - go n (Var v) = isDeadEndId v && n >= idArity v + go n (Var v) = isDeadEndAppSig (idStrictness v) n go n (App e a) | isTypeArg a = go n e | otherwise = go (n+1) e go n (Tick _ e) = go n e diff --git a/compiler/GHC/Data/IOEnv.hs b/compiler/GHC/Data/IOEnv.hs --- a/compiler/GHC/Data/IOEnv.hs +++ b/compiler/GHC/Data/IOEnv.hs @@ -60,7 +60,7 @@ newtype IOEnv env a = IOEnv' (env -> IO a) - deriving (MonadThrow, MonadCatch, MonadMask) via (ReaderT env IO) + deriving (MonadThrow, MonadCatch, MonadMask, MonadFix) via (ReaderT env IO) -- See Note [The one-shot state monad trick] in GHC.Utils.Monad instance Functor (IOEnv env) where diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs --- a/compiler/GHC/Driver/Errors.hs +++ b/compiler/GHC/Driver/Errors.hs @@ -46,10 +46,14 @@ handleFlagWarnings logger dflags warns = do let warns' = filter (shouldPrintWarning dflags . CmdLine.warnReason) warns + toWarnReason CmdLine.ReasonDeprecatedFlag = Reason Opt_WarnDeprecatedFlags + toWarnReason CmdLine.ReasonUnrecognisedFlag = Reason Opt_WarnUnrecognisedWarningFlags + toWarnReason CmdLine.NoReason = NoReason + -- It would be nicer if warns :: [Located SDoc], but that -- has circular import problems. - bag = listToBag [ mkPlainWarnMsg loc (text warn) - | CmdLine.Warn _ (L loc warn) <- warns' ] + bag = listToBag [ makeIntoWarning (toWarnReason reason) (mkPlainWarnMsg loc (text warn)) + | CmdLine.Warn reason (L loc warn) <- warns' ] printOrThrowWarnings logger dflags bag diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -1373,12 +1373,14 @@ LangExt.DatatypeContexts, LangExt.TraditionalRecordSyntax, LangExt.FieldSelectors, - LangExt.NondecreasingIndentation + LangExt.NondecreasingIndentation, -- strictly speaking non-standard, but we always had this -- on implicitly before the option was added in 7.1, and -- turning it off breaks code, so we're keeping it on for -- backwards compatibility. Cabal uses -XHaskell98 by -- default unless you specify another language. + LangExt.DeepSubsumption + -- Non-standard but enabled for backwards compatability (see GHC proposal #511) ] languageExtensions (Just Haskell2010) @@ -1394,7 +1396,8 @@ LangExt.PatternGuards, LangExt.DoAndIfThenElse, LangExt.FieldSelectors, - LangExt.RelaxedPolyRec] + LangExt.RelaxedPolyRec, + LangExt.DeepSubsumption ] languageExtensions (Just GHC2021) = [LangExt.ImplicitPrelude, @@ -2450,7 +2453,7 @@ , make_ord_flag defGhcFlag "ddump-asm-expanded" (setDumpFlag Opt_D_dump_asm_expanded) , make_ord_flag defGhcFlag "ddump-llvm" - (NoArg $ setObjBackend LLVM >> setDumpFlag' Opt_D_dump_llvm) + (NoArg $ setDumpFlag' Opt_D_dump_llvm) , make_ord_flag defGhcFlag "ddump-c-backend" (NoArg $ setDumpFlag' Opt_D_dump_c_backend) , make_ord_flag defGhcFlag "ddump-deriv" @@ -3612,6 +3615,7 @@ flagSpec "MagicHash" LangExt.MagicHash, flagSpec "MonadComprehensions" LangExt.MonadComprehensions, flagSpec "MonoLocalBinds" LangExt.MonoLocalBinds, + flagSpec "DeepSubsumption" LangExt.DeepSubsumption, flagSpec "MonomorphismRestriction" LangExt.MonomorphismRestriction, flagSpec "MultiParamTypeClasses" LangExt.MultiParamTypeClasses, flagSpec "MultiWayIf" LangExt.MultiWayIf, @@ -4012,7 +4016,8 @@ Opt_WarnSpaceAfterBang, Opt_WarnNonCanonicalMonadInstances, Opt_WarnNonCanonicalMonoidInstances, - Opt_WarnOperatorWhitespaceExtConflict + Opt_WarnOperatorWhitespaceExtConflict, + Opt_WarnUnicodeBidirectionalFormatCharacters ] -- | Things you get with -W diff --git a/compiler/GHC/Parser/Errors.hs b/compiler/GHC/Parser/Errors.hs --- a/compiler/GHC/Parser/Errors.hs +++ b/compiler/GHC/Parser/Errors.hs @@ -367,6 +367,9 @@ | PsErrLinearFunction -- ^ Linear function found but LinearTypes not enabled + | PsErrInvalidCApiImport + -- ^ Invalid CApi import + | PsErrMultiWayIf -- ^ Multi-way if-expression found but MultiWayIf not enabled diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/compiler/GHC/Parser/Errors/Ppr.hs @@ -584,6 +584,9 @@ PsErrLinearFunction -> text "Enable LinearTypes to allow linear functions" + PsErrInvalidCApiImport {} + -> text "Wrapper stubs can't be used with CApiFFI." + PsErrMultiWayIf -> text "Multi-way if-expressions need MultiWayIf turned on" diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -2500,9 +2500,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 $ PsError PsErrInvalidCApiImport [] loc + else returnSpec imp + StdCallConv -> returnSpec =<< mkCImport PrimCallConv -> mkOtherImport JavaScriptCallConv -> mkOtherImport where @@ -2514,7 +2518,10 @@ let e = unpackFS entity case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of Nothing -> addFatalError $ PsError PsErrMalformedEntityString [] loc - 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. diff --git a/compiler/GHC/Platform.hs b/compiler/GHC/Platform.hs --- a/compiler/GHC/Platform.hs +++ b/compiler/GHC/Platform.hs @@ -218,6 +218,11 @@ ArchPPC_64 _ -> True ArchS390X -> True ArchRISCV64 -> True + ArchAArch64 + -- Apple's AArch64 ABI requires that the caller sign-extend + -- small integer arguments. See + -- https://developer.apple.com/documentation/xcode/writing-arm64-code-for-apple-platforms + | OSDarwin <- platformOS platform -> True _ -> False diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs --- a/compiler/GHC/Tc/Types/Origin.hs +++ b/compiler/GHC/Tc/Types/Origin.hs @@ -461,7 +461,7 @@ -- We only need a CtOrigin on the first, because the location -- is pinned on the entire error message - | ExprHoleOrigin OccName -- from an expression hole + | ExprHoleOrigin (Maybe OccName) -- from an expression hole | TypeHoleOrigin OccName -- from a type hole (partial type signature) | PatCheckOrigin -- normalisation of a type during pattern-match checking | ListOrigin -- An overloaded list @@ -481,6 +481,13 @@ CtOrigin -- origin of the original constraint -- See Detail (7) of Note [Type equality cycles] in GHC.Tc.Solver.Canonical + | InstanceSigOrigin -- from the sub-type check of an InstanceSig + Name -- the method name + Type -- the instance-sig type + Type -- the instantiated type of the method + | AmbiguityCheckOrigin UserTypeCtxt + | GhcBug20076 + -- | The number of superclass selections needed to get this Given. -- If @d :: C ty@ has @ScDepth=2@, then the evidence @d@ will look -- like @sc_sel (sc_sel dg)@, where @dg@ is a Given. @@ -660,6 +667,18 @@ pprCtOrigin (CycleBreakerOrigin orig) = pprCtOrigin orig +pprCtOrigin (InstanceSigOrigin method_name sig_type orig_method_type) + = vcat [ ctoHerald <+> text "the check that an instance signature is more general" + , text "than the type of the method (instantiated for this instance)" + , hang (text "instance signature:") + 2 (ppr method_name <+> dcolon <+> ppr sig_type) + , hang (text "instantiated method type:") + 2 (ppr orig_method_type) ] + +pprCtOrigin (AmbiguityCheckOrigin ctxt) + = ctoHerald <+> text "a type ambiguity check for" $$ + pprUserTypeCtxt ctxt + pprCtOrigin simple_origin = ctoHerald <+> pprCtO simple_origin @@ -693,7 +712,8 @@ pprCtO MCompOrigin = text "a statement in a monad comprehension" pprCtO ProcOrigin = text "a proc expression" pprCtO AnnOrigin = text "an annotation" -pprCtO (ExprHoleOrigin occ) = text "a use of" <+> quotes (ppr occ) +pprCtO (ExprHoleOrigin Nothing) = text "an expression hole" +pprCtO (ExprHoleOrigin (Just occ)) = text "a use of" <+> quotes (ppr occ) pprCtO (TypeHoleOrigin occ) = text "a use of wildcard" <+> quotes (ppr occ) pprCtO PatCheckOrigin = text "a pattern-match completeness check" pprCtO ListOrigin = text "an overloaded list" @@ -701,4 +721,7 @@ pprCtO NonLinearPatternOrigin = text "a non-linear pattern" pprCtO (UsageEnvironmentOf x) = hsep [text "multiplicity of", quotes (ppr x)] pprCtO BracketOrigin = text "a quotation bracket" +pprCtO (InstanceSigOrigin {}) = text "a type signature in an instance" +pprCtO (AmbiguityCheckOrigin {}) = text "a type ambiguity check" +pprCtO GhcBug20076 = text "GHC Bug #20076" pprCtO _ = panic "pprCtOrigin" diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs --- a/compiler/GHC/Tc/Utils/TcType.hs +++ b/compiler/GHC/Tc/Utils/TcType.hs @@ -1316,34 +1316,50 @@ (tvs, rho) -> case tcSplitPhiTy rho of (theta, tau) -> (tvs, theta, tau) --- | Split a sigma type into its parts, going underneath as many @ForAllTy@s --- as possible. For example, given this type synonym: --- --- @ --- type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t --- @ --- --- if you called @tcSplitSigmaTy@ on this type: --- --- @ --- forall s t a b. Each s t a b => Traversal s t a b --- @ --- --- then it would return @([s,t,a,b], [Each s t a b], Traversal s t a b)@. But --- if you instead called @tcSplitNestedSigmaTys@ on the type, it would return --- @([s,t,a,b,f], [Each s t a b, Applicative f], (a -> f b) -> s -> f t)@. +-- | Split a sigma type into its parts, going underneath as many arrows +-- and foralls as possible. See Note [tcSplitNestedSigmaTys] tcSplitNestedSigmaTys :: Type -> ([TyVar], ThetaType, Type) --- NB: This is basically a pure version of topInstantiate (from Inst) that --- doesn't compute an HsWrapper. +-- See Note [tcSplitNestedSigmaTys] +-- NB: This is basically a pure version of deeplyInstantiate (from Unify) that +-- doesn't compute an HsWrapper. tcSplitNestedSigmaTys ty -- If there's a forall, split it apart and try splitting the rho type -- underneath it. - | (tvs1, theta1, rho1) <- tcSplitSigmaTy ty + | (arg_tys, body_ty) <- tcSplitFunTys ty + , (tvs1, theta1, rho1) <- tcSplitSigmaTy body_ty , not (null tvs1 && null theta1) = let (tvs2, theta2, rho2) = tcSplitNestedSigmaTys rho1 - in (tvs1 ++ tvs2, theta1 ++ theta2, rho2) + in (tvs1 ++ tvs2, theta1 ++ theta2, mkVisFunTys arg_tys rho2) + -- If there's no forall, we're done. | otherwise = ([], [], ty) + +{- Note [tcSplitNestedSigmaTys] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tcSplitNestedSigmaTys splits out all the /nested/ foralls and constraints, +including under function arrows. E.g. given this type synonym: + type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t + +then + tcSplitNestedSigmaTys (forall s t a b. C s t a b => Int -> Traversal s t a b) + +will return + ( [s,t,a,b,f] + , [C s t a b, Applicative f] + , Int -> (a -> f b) -> s -> f t)@. + +This function is used in these places: +* Improving error messages in GHC.Tc.Gen.Head.addFunResCtxt +* Validity checking for default methods: GHC.Tc.TyCl.checkValidClass +* A couple of calls in the GHCi debugger: GHC.Runtime.Heap.Inspect + +In other words, just in validity checking and error messages; hence +no wrappers or evidence generation. + +Notice that tcSplitNestedSigmaTys even looks under function arrows; +doing so is the Right Thing even with simple subsumption, not just +with deep subsumption. +-} ----------------------- tcTyConAppTyCon :: Type -> TyCon diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -60,7 +60,7 @@ -- * Demand signatures StrictSig(..), mkStrictSigForArity, mkClosedStrictSig, splitStrictSig, strictSigDmdEnv, hasDemandEnvSig, - nopSig, botSig, isTopSig, isDeadEndSig, appIsDeadEnd, + nopSig, botSig, isTopSig, isDeadEndSig, isDeadEndAppSig, -- ** Handling arity adjustments prependArgsStrictSig, etaConvertStrictSig, @@ -1468,15 +1468,15 @@ isDeadEndSig :: StrictSig -> Bool isDeadEndSig (StrictSig (DmdType _ _ res)) = isDeadEndDiv res --- | Returns true if an application to n args would diverge or throw an +-- | Returns true if an application to n value args would diverge or throw an -- exception. -- -- If a function having 'botDiv' is applied to a less number of arguments than -- its syntactic arity, we cannot say for sure that it is going to diverge. -- Hence this function conservatively returns False in that case. -- See Note [Dead ends]. -appIsDeadEnd :: StrictSig -> Int -> Bool -appIsDeadEnd (StrictSig (DmdType _ ds res)) n +isDeadEndAppSig :: StrictSig -> Int -> Bool +isDeadEndAppSig (StrictSig (DmdType _ ds res)) n = isDeadEndDiv res && not (lengthExceeds ds n) prependArgsStrictSig :: Int -> StrictSig -> StrictSig diff --git a/compiler/GHC/Unit/Module/Graph.hs b/compiler/GHC/Unit/Module/Graph.hs --- a/compiler/GHC/Unit/Module/Graph.hs +++ b/compiler/GHC/Unit/Module/Graph.hs @@ -72,9 +72,9 @@ -- 'GHC.topSortModuleGraph' and 'GHC.Data.Graph.Directed.flattenSCC' to achieve this. data ModuleGraph = ModuleGraph { mg_mss :: [ModuleGraphNode] - , mg_non_boot :: ModuleEnv ModSummary + , mg_non_boot :: !(ModuleEnv ModSummary) -- a map of all non-boot ModSummaries keyed by Modules - , mg_boot :: ModuleSet + , mg_boot :: !ModuleSet -- a set of boot Modules , mg_needs_th_or_qq :: !Bool -- does any of the modules in mg_mss require TemplateHaskell or diff --git a/ghc-lib-parser.cabal b/ghc-lib-parser.cabal --- a/ghc-lib-parser.cabal +++ b/ghc-lib-parser.cabal @@ -1,7 +1,7 @@ cabal-version: 2.0 build-type: Simple name: ghc-lib-parser -version: 9.2.3.20220709 +version: 9.2.4.20220729 license: BSD3 license-file: LICENSE category: Development diff --git a/ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl b/ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl @@ -92,6 +92,7 @@ primOpOutOfLine CompactSize = True primOpOutOfLine GetSparkOp = True primOpOutOfLine NumSparks = True +primOpOutOfLine KeepAliveOp = True primOpOutOfLine MkApUpd0_Op = True primOpOutOfLine NewBCOOp = True primOpOutOfLine UnpackClosureOp = True diff --git a/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs b/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs --- a/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs +++ b/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs @@ -3,19 +3,19 @@ import Prelude -- See Note [Why do we import Prelude here?] cProjectGitCommitId :: String -cProjectGitCommitId = "a2f693f524830c2ab1e8a6e9d729839ac8b468c5" +cProjectGitCommitId = "a54827e0b48af33fa9cfde6ad131c6751c2fe321" cProjectVersion :: String -cProjectVersion = "9.2.3" +cProjectVersion = "9.2.4" cProjectVersionInt :: String cProjectVersionInt = "902" cProjectPatchLevel :: String -cProjectPatchLevel = "3" +cProjectPatchLevel = "4" cProjectPatchLevel1 :: String -cProjectPatchLevel1 = "3" +cProjectPatchLevel1 = "4" cProjectPatchLevel2 :: String cProjectPatchLevel2 = "" diff --git a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs --- a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs +++ b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs @@ -30,6 +30,7 @@ | UndecidableSuperClasses | MonomorphismRestriction | MonoLocalBinds + | DeepSubsumption | RelaxedPolyRec -- Deprecated | ExtendedDefaultRules -- Use GHC's extended rules for defaulting | ForeignFunctionInterface diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs --- a/libraries/ghci/GHCi/Message.hs +++ b/libraries/ghci/GHCi/Message.hs @@ -462,7 +462,7 @@ #define MIN_VERSION_ghc_heap(major1,major2,minor) (\ (major1) < 9 || \ (major1) == 9 && (major2) < 2 || \ - (major1) == 9 && (major2) == 2 && (minor) <= 3) + (major1) == 9 && (major2) == 2 && (minor) <= 4) #endif /* MIN_VERSION_ghc_heap */ #if MIN_VERSION_ghc_heap(8,11,0) instance Binary Heap.StgTSOProfInfo