ghc 9.4.2 → 9.4.3
raw patch · 37 files changed
+996/−411 lines, 37 filesdep ~ghc-bootdep ~ghc-heapdep ~ghciPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: ghc-boot, ghc-heap, ghci
API changes (from Hackage documentation)
- GHC.Core.Opt.Arity: mkTopArityType :: [OneShotInfo] -> ArityType
- GHC.Core.Tidy: tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding
- GHC.StgToCmm.Prof: emitInfoTableProv :: InfoProvEnt -> FCode ()
- GHC.Utils.Binary: instance GHC.Utils.Binary.Binary GHC.Types.SrcLoc.BufPos
- GHC.Utils.Binary: instance GHC.Utils.Binary.Binary GHC.Types.SrcLoc.BufSpan
- Language.Haskell.Syntax.Expr: instance GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Extension.XRec p GHC.Types.FieldLabel.FieldLabelString) => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Expr.DotFieldOcc p)
+ GHC.Core.Opt.Arity: mkManifestArityType :: [Var] -> CoreExpr -> ArityType
+ GHC.Core.Opt.Simplify.Env: [seRecIds] :: SimplEnv -> !UnVarSet
+ GHC.Core.Opt.Simplify.Env: enterRecGroupRHSs :: SimplEnv -> [OutBndr] -> (SimplEnv -> SimplM (r, SimplEnv)) -> SimplM (r, SimplEnv)
+ GHC.Core.Tidy: tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])
+ GHC.Core.Utils: exprOkForSpecEval :: (Id -> Bool) -> CoreExpr -> Bool
+ GHC.Data.Graph.UnVar: delUnVarSetList :: UnVarSet -> [Var] -> UnVarSet
+ GHC.Data.Graph.UnVar: extendUnVarSetList :: [Var] -> UnVarSet -> UnVarSet
+ GHC.StgToCmm.InfoTableProv: emitIpeBufferListNode :: Module -> [InfoProvEnt] -> FCode ()
+ GHC.Types.SrcLoc: removeBufSpan :: SrcSpan -> SrcSpan
+ Language.Haskell.Syntax.Expr: instance Language.Haskell.Syntax.Extension.UnXRec p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Expr.DotFieldOcc p)
+ Language.Haskell.Syntax.Expr: pprPrefixFastString :: FastString -> SDoc
+ Language.Haskell.Syntax.Expr: pprPrefixFieldLabelString :: forall p. UnXRec p => DotFieldOcc p -> SDoc
+ Language.Haskell.Syntax.Expr: pprPrefixFieldLabelStrings :: forall p. (UnXRec p, Outputable (XRec p FieldLabelString)) => FieldLabelStrings p -> SDoc
- GHC.Cmm.CLabel: mkIPELabel :: InfoProvEnt -> CLabel
+ GHC.Cmm.CLabel: mkIPELabel :: Module -> CLabel
- GHC.Core.Opt.Simplify.Env: SimplEnv :: !SimplMode -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> !InScopeSet -> !Int -> SimplEnv
+ GHC.Core.Opt.Simplify.Env: SimplEnv :: !SimplMode -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> !UnVarSet -> !InScopeSet -> !Int -> SimplEnv
- GHC.Core.Utils: tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr
+ GHC.Core.Utils: tryEtaReduce :: UnVarSet -> [Var] -> CoreExpr -> Maybe CoreExpr
- GHC.Driver.CodeOutput: ipInitCode :: Bool -> Platform -> Module -> [InfoProvEnt] -> CStub
+ GHC.Driver.CodeOutput: ipInitCode :: Bool -> Platform -> Module -> CStub
Files
- GHC/Cmm/CLabel.hs +6/−2
- GHC/Cmm/Lexer.hs +2/−2
- GHC/Cmm/Parser.hs +9/−4
- GHC/CmmToAsm/AArch64/CodeGen.hs +20/−12
- GHC/CmmToLlvm/Base.hs +16/−4
- GHC/Core.hs +1/−0
- GHC/Core/Opt/Arity.hs +290/−102
- GHC/Core/Opt/CprAnal.hs +7/−6
- GHC/Core/Opt/Simplify.hs +43/−14
- GHC/Core/Opt/Simplify/Env.hs +25/−25
- GHC/Core/Opt/Simplify/Utils.hs +3/−4
- GHC/Core/Opt/SpecConstr.hs +31/−14
- GHC/Core/SimpleOpt.hs +23/−5
- GHC/Core/Tidy.hs +19/−16
- GHC/Core/Utils.hs +47/−32
- GHC/CoreToStg/Prep.hs +81/−10
- GHC/Data/Graph/UnVar.hs +7/−1
- GHC/Driver/CodeOutput.hs +8/−17
- GHC/Driver/Main.hs +6/−5
- GHC/Hs/Expr.hs +1/−1
- GHC/Hs/Syn/Type.hs +3/−3
- GHC/Iface/Ext/Ast.hs +5/−2
- GHC/Iface/Ext/Types.hs +2/−2
- GHC/Iface/Tidy.hs +83/−40
- GHC/Parser/HaddockLex.hs +2/−2
- GHC/Parser/Lexer.hs +2/−2
- GHC/Parser/PostProcess.hs +1/−1
- GHC/StgToCmm/InfoTableProv.hs +131/−0
- GHC/StgToCmm/Prof.hs +11/−38
- GHC/Tc/Deriv/Functor.hs +30/−2
- GHC/Tc/Deriv/Generics.hs +18/−3
- GHC/Tc/Deriv/Infer.hs +33/−16
- GHC/Types/Id/Info.hs +1/−1
- GHC/Types/SrcLoc.hs +5/−0
- GHC/Utils/Binary.hs +4/−17
- Language/Haskell/Syntax/Expr.hs +15/−2
- ghc.cabal +5/−4
GHC/Cmm/CLabel.hs view
@@ -302,6 +302,7 @@ | MLK_InitializerArray | MLK_Finalizer String | MLK_FinalizerArray+ | MLK_IPEBuffer deriving (Eq, Ord) instance Outputable ModuleLabelKind where@@ -309,6 +310,7 @@ ppr (MLK_Initializer s) = text ("init__" ++ s) ppr MLK_FinalizerArray = text "fini_arr" ppr (MLK_Finalizer s) = text ("fini__" ++ s)+ ppr MLK_IPEBuffer = text "ipe_buf" isIdLabel :: CLabel -> Bool isIdLabel IdLabel{} = True@@ -830,10 +832,10 @@ -- Constructing Cost Center Labels mkCCLabel :: CostCentre -> CLabel mkCCSLabel :: CostCentreStack -> CLabel-mkIPELabel :: InfoProvEnt -> CLabel+mkIPELabel :: Module -> CLabel mkCCLabel cc = CC_Label cc mkCCSLabel ccs = CCS_Label ccs-mkIPELabel ipe = IPE_Label ipe+mkIPELabel mod = ModuleLabel mod MLK_IPEBuffer mkRtsApFastLabel :: FastString -> CLabel mkRtsApFastLabel str = RtsLabel (RtsApFast (NonDetFastString str))@@ -1011,6 +1013,7 @@ -- Code for finalizers and initializers are emitted in stub objects modLabelNeedsCDecl (MLK_Initializer _) = True modLabelNeedsCDecl (MLK_Finalizer _) = True+modLabelNeedsCDecl MLK_IPEBuffer = True -- The finalizer and initializer arrays are emitted in the code of the module modLabelNeedsCDecl MLK_InitializerArray = False modLabelNeedsCDecl MLK_FinalizerArray = False@@ -1208,6 +1211,7 @@ MLK_InitializerArray -> DataLabel MLK_Finalizer _ -> CodeLabel MLK_FinalizerArray -> DataLabel+ MLK_IPEBuffer -> DataLabel idInfoLabelType :: IdLabelInfo -> CLabelType idInfoLabelType info =
GHC/Cmm/Lexer.hs view
@@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}-{-# LINE 13 "_build/source-dist/ghc-9.4.2-src/ghc-9.4.2/compiler/GHC/Cmm/Lexer.x" #-}+{-# LINE 13 "_build/source-dist/ghc-9.4.3-src/ghc-9.4.3/compiler/GHC/Cmm/Lexer.x" #-} module GHC.Cmm.Lexer ( CmmToken(..), cmmlex, ) where@@ -354,7 +354,7 @@ , (0,alex_action_19) ] -{-# LINE 129 "_build/source-dist/ghc-9.4.2-src/ghc-9.4.2/compiler/GHC/Cmm/Lexer.x" #-}+{-# LINE 129 "_build/source-dist/ghc-9.4.3-src/ghc-9.4.3/compiler/GHC/Cmm/Lexer.x" #-} data CmmToken = CmmT_SpecChar Char | CmmT_DotDot
GHC/Cmm/Parser.hs view
@@ -34,6 +34,7 @@ import GHC.StgToCmm.Ticky import GHC.StgToCmm.Prof import GHC.StgToCmm.Bind ( emitBlackHoleCode, emitUpdateFrame )+import GHC.StgToCmm.InfoTableProv import GHC.Cmm.Opt import GHC.Cmm.Graph@@ -3359,14 +3360,18 @@ POk pst code -> do st <- initC let fstate = F.initFCodeState (profilePlatform $ targetProfile dflags)+ let config = initStgToCmmConfig dflags no_module let fcode = do ((), cmm) <- getCmm $ unEC code "global" (initEnv (targetProfile dflags)) [] >> return () -- See Note [Mapping Info Tables to Source Positions] (IPE Maps)- let used_info = map (cmmInfoTableToInfoProvEnt this_mod)- (mapMaybe topInfoTable cmm)- ((), cmm2) <- getCmm $ mapM_ emitInfoTableProv used_info+ let used_info+ | do_ipe = map (cmmInfoTableToInfoProvEnt this_mod) (mapMaybe topInfoTable cmm)+ | otherwise = []+ where+ do_ipe = stgToCmmInfoTableMap config+ ((), cmm2) <- getCmm $ emitIpeBufferListNode this_mod used_info return (cmm ++ cmm2, used_info)- (cmm, _) = runC (initStgToCmmConfig dflags no_module) fstate st fcode+ (cmm, _) = runC config fstate st fcode (warnings,errors) = getPsMessages pst if not (isEmptyMessages errors) then return (warnings, errors, Nothing)
GHC/CmmToAsm/AArch64/CodeGen.hs view
@@ -662,10 +662,11 @@ -- See Note [Signed arithmetic on AArch64]. negate code w reg = do let w' = opRegWidth w+ (reg', code_sx) <- signExtendReg w w' reg return $ Any (intFormat w) $ \dst -> code `appOL`- signExtendReg w w' reg `snocOL`- NEG (OpReg w' dst) (OpReg w' reg) `appOL`+ code_sx `snocOL`+ NEG (OpReg w' dst) (OpReg w' reg') `appOL` truncateReg w' w dst ss_conv from to reg code =@@ -815,15 +816,17 @@ -- should be performed. let w' = opRegWidth w signExt r- | not is_signed = nilOL+ | not is_signed = return (r, nilOL) | otherwise = signExtendReg w w' r+ (reg_x_sx, code_x_sx) <- signExt reg_x+ (reg_y_sx, code_y_sx) <- signExt reg_y return $ Any (intFormat w) $ \dst -> code_x `appOL` code_y `appOL` -- sign-extend both operands- signExt reg_x `appOL`- signExt reg_y `appOL`- op (OpReg w' dst) (OpReg w' reg_x) (OpReg w' reg_y) `appOL`+ code_x_sx `appOL`+ code_y_sx `appOL`+ op (OpReg w' dst) (OpReg w' reg_x_sx) (OpReg w' reg_y_sx) `appOL` truncateReg w' w dst -- truncate back to the operand's original width floatOp w op = do@@ -1019,16 +1022,21 @@ -- | Instructions to sign-extend the value in the given register from width @w@ -- up to width @w'@.-signExtendReg :: Width -> Width -> Reg -> OrdList Instr+signExtendReg :: Width -> Width -> Reg -> NatM (Reg, OrdList Instr) signExtendReg w w' r = case w of- W64 -> nilOL+ W64 -> noop W32- | w' == W32 -> nilOL- | otherwise -> unitOL $ SXTH (OpReg w' r) (OpReg w' r)- W16 -> unitOL $ SXTH (OpReg w' r) (OpReg w' r)- W8 -> unitOL $ SXTB (OpReg w' r) (OpReg w' r)+ | w' == W32 -> noop+ | otherwise -> extend SXTH+ W16 -> extend SXTH+ W8 -> extend SXTB _ -> panic "intOp"+ where+ noop = return (r, nilOL)+ extend instr = do+ r' <- getNewRegNat II64+ return (r', unitOL $ instr (OpReg w' r') (OpReg w' r)) -- | Instructions to truncate the value in the given register from width @w@ -- down to width @w'@.
GHC/CmmToLlvm/Base.hs view
@@ -67,7 +67,7 @@ import Data.Maybe (fromJust) import Control.Monad (ap) import Data.Char (isDigit)-import Data.List (sortBy, groupBy, intercalate)+import Data.List (sortBy, groupBy, intercalate, isPrefixOf) import Data.Ord (comparing) import qualified Data.List.NonEmpty as NE @@ -550,6 +550,12 @@ modifyEnv $ \env -> env { envAliases = emptyUniqSet } return (concat defss, []) +-- | Is a variable one of the special @$llvm@ globals?+isBuiltinLlvmVar :: LlvmVar -> Bool+isBuiltinLlvmVar (LMGlobalVar lbl _ _ _ _ _) =+ "$llvm" `isPrefixOf` unpackFS lbl+isBuiltinLlvmVar _ = False+ -- | Here we take a global variable definition, rename it with a -- @$def@ suffix, and generate the appropriate alias. aliasify :: LMGlobal -> LlvmM [LMGlobal]@@ -557,8 +563,9 @@ -- Here we obtain the indirectee's precise type and introduce -- fresh aliases to both the precise typed label (lbl$def) and the i8* -- typed (regular) label of it with the matching new names.-aliasify (LMGlobal (LMGlobalVar lbl ty@LMAlias{} link sect align Alias)- (Just orig)) = do+aliasify (LMGlobal var@(LMGlobalVar lbl ty@LMAlias{} link sect align Alias)+ (Just orig))+ | not $ isBuiltinLlvmVar var = do let defLbl = llvmDefLabel lbl LMStaticPointer (LMGlobalVar origLbl _ oLnk Nothing Nothing Alias) = orig defOrigLbl = llvmDefLabel origLbl@@ -571,7 +578,8 @@ pure [ LMGlobal (LMGlobalVar defLbl ty link sect align Alias) (Just defOrig) , LMGlobal (LMGlobalVar lbl i8Ptr link sect align Alias) (Just orig') ]-aliasify (LMGlobal var val) = do+aliasify (LMGlobal var val)+ | not $ isBuiltinLlvmVar var = do let LMGlobalVar lbl ty link sect align const = var defLbl = llvmDefLabel lbl@@ -589,6 +597,7 @@ return [ LMGlobal defVar val , LMGlobal aliasVar (Just aliasVal) ]+aliasify global = pure [global] -- Note [Llvm Forward References] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -647,3 +656,6 @@ -- away with casting the alias to the desired type in @getSymbolPtr@ -- and instead just emit a reference to the definition symbol directly. -- This is the @Just@ case in @getSymbolPtr@.+--+-- Note that we must take care not to turn LLVM's builtin variables into+-- aliases (e.g. $llvm.global_ctors) since this confuses LLVM.
GHC/Core.hs view
@@ -739,6 +739,7 @@ The arity of a join point isn't very important; but short of setting it to zero, it is helpful to have an invariant. E.g. #17294.+ See also Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils. 3. If the binding is recursive, then all other bindings in the recursive group must also be join points.
GHC/Core/Opt/Arity.hs view
@@ -17,7 +17,7 @@ , exprBotStrictness_maybe -- ** ArityType- , ArityType(..), mkBotArityType, mkTopArityType, expandableArityType+ , ArityType(..), mkBotArityType, mkManifestArityType, expandableArityType , arityTypeArity, maxWithArity, idArityType -- ** Join points@@ -53,7 +53,6 @@ import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Id-import GHC.Types.Var.Set import GHC.Types.Basic import GHC.Types.Tickish @@ -505,6 +504,67 @@ Then f :: \??.T f v :: \?.T f <expensive> :: T++++Note [Eta reduction in recursive RHSs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following recursive function:+ f = \x. ....g (\y. f y)....+The recursive call of f in its own RHS seems like a fine opportunity for+eta-reduction because f has arity 1. And often it is!++Alas, that is unsound in general if the eta-reduction happens in a tail context.+Making the arity visible in the RHS allows us to eta-reduce+ f = \x -> f x+to+ f = f+which means we optimise terminating programs like (f `seq` ()) into+non-terminating ones. Nor is this problem just for tail calls. Consider+ f = id (\x -> f x)+where we have (for some reason) not yet inlined `id`. We must not eta-reduce to+ f = id f+because that will then simplify to `f = f` as before.++An immediate idea might be to look at whether the called function is a local+loopbreaker and refrain from eta-expanding. But that doesn't work for mutually+recursive function like in #21652:+ f = g+ g* x = f x+Here, g* is the loopbreaker but f isn't.++What can we do?++Fix 1: Zap `idArity` when analysing recursive RHSs and re-attach the info when+ entering the let body.+ Has the disadvantage that other transformations which make use of arity+ (such as dropping of `seq`s when arity > 0) will no longer work in the RHS.+ Plus it requires non-trivial refactorings to both the simple optimiser (in+ the way `subst_opt_bndr` is used) as well as the Simplifier (in the way+ `simplRecBndrs` and `simplRecJoinBndrs` is used), modifying the SimplEnv's+ substitution twice in the process. A very complicated stop-gap.++Fix 2: Pass the set of enclosing recursive binders to `tryEtaReduce`; these are+ the ones we should not eta-reduce. All call-site must maintain this set.+ Example:+ rec { f1 = ....rec { g = ... (\x. g x)...(\y. f2 y)... }...+ ; f2 = ...f1... }+ when eta-reducing those inner lambdas, we need to know that we are in the+ rec group for {f1, f2, g}.+ This is very much like the solution in Note [Speculative evaluation] in+ GHC.CoreToStg.Prep.+ It is a bit tiresome to maintain this info, because it means another field+ in SimplEnv and SimpleOptEnv.++We implement Fix (2) because of it isn't as complicated to maintain as (1).+Plus, it is the correct fix to begin with. After all, the arity is correct,+but doing the transformation isn't. The moving parts are:+ * A field `scRecIds` in `SimplEnv` tracks the enclosing recursive binders+ * We extend the `scRecIds` set in `GHC.Core.Opt.Simplify.simplRecBind`+ * We consult the set in `is_eta_reduction_sound` in `tryEtaReduce`+The situation is very similar to Note [Speculative evaluation] which has the+same fix.+ -} @@ -533,7 +593,8 @@ -- where the @at@ fields of @ALam@ are inductively subject to the same order. -- That is, @ALam os at1 < ALam os at2@ iff @at1 < at2@. ----- Why the strange Top element? See Note [Combining case branches].+-- Why the strange Top element?+-- See Note [Combining case branches: optimistic one-shot-ness] -- -- We rely on this lattice structure for fixed-point iteration in -- 'findRhsArity'. For the semantics of 'ArityType', see Note [ArityType].@@ -580,11 +641,16 @@ botArityType :: ArityType botArityType = mkBotArityType [] -mkTopArityType :: [OneShotInfo] -> ArityType-mkTopArityType oss = AT oss topDiv+mkManifestArityType :: [Var] -> CoreExpr -> ArityType+mkManifestArityType bndrs body+ = AT oss div+ where+ oss = [idOneShotInfo bndr | bndr <- bndrs, isId bndr]+ div | exprIsDeadEnd body = botDiv+ | otherwise = topDiv topArityType :: ArityType-topArityType = mkTopArityType []+topArityType = AT [] topDiv -- | The number of value args for the arity type arityTypeArity :: ArityType -> Arity@@ -624,7 +690,7 @@ exprEtaExpandArity :: DynFlags -> CoreExpr -> ArityType -- exprEtaExpandArity is used when eta expanding -- e ==> \xy -> e x y-exprEtaExpandArity dflags e = arityType (etaExpandArityEnv dflags) e+exprEtaExpandArity dflags e = arityType (findRhsArityEnv dflags) e getBotArity :: ArityType -> Maybe Arity -- Arity of a divergent function@@ -764,6 +830,7 @@ | otherwise = takeWhileOneShot at arityApp :: ArityType -> Bool -> ArityType+ -- Processing (fun arg) where at is the ArityType of fun, -- Knock off an argument and behave like 'let' arityApp (AT (_:oss) div) cheap = floatIn cheap (AT oss div)@@ -773,17 +840,31 @@ -- See the haddocks on 'ArityType' for the lattice. -- -- Used for branches of a @case@.-andArityType :: ArityType -> ArityType -> ArityType-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 at1@(AT [] div1) at2- | isDeadEndDiv div1 = at2 -- Note [ABot branches: max arity wins]- | otherwise = at1 -- See Note [Combining case branches]-andArityType at1 at2@(AT [] div2)- | isDeadEndDiv div2 = at1 -- Note [ABot branches: max arity wins]- | otherwise = at2 -- See Note [Combining case branches]+andArityType :: ArityEnv -> ArityType -> ArityType -> ArityType+andArityType env (AT (lam1:lams1) div1) (AT (lam2:lams2) div2)+ | AT lams' div' <- andArityType env (AT lams1 div1) (AT lams2 div2)+ = AT ((lam1 `and_lam` lam2) : lams') div'+ where+ (os1) `and_lam` (os2)+ = ( os1 `bestOneShot` os2)+ -- bestOneShot: see Note [Combining case branches: optimistic one-shot-ness] +andArityType env (AT [] div1) at2 = andWithTail env div1 at2+andArityType env at1 (AT [] div2) = andWithTail env div2 at1++andWithTail :: ArityEnv -> Divergence -> ArityType -> ArityType+andWithTail env div1 at2@(AT lams2 _)+ | isDeadEndDiv div1 -- case x of { T -> error; F -> \y.e }+ = at2 -- Note [ABot branches: max arity wins]++ | pedanticBottoms env -- Note [Combining case branches: andWithTail]+ = AT [] topDiv++ | otherwise -- case x of { T -> plusInt <expensive>; F -> \y.e }+ = AT lams2 topDiv -- We know div1 = topDiv+ -- See Note [Combining case branches: andWithTail]++ {- Note [ABot branches: max arity wins] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider case x of@@ -793,9 +874,61 @@ Remember: \o1..on.⊥ means "if you apply to n args, it'll definitely diverge". So we need \??.⊥ for the whole thing, the /max/ of both arities. -Note [Combining case branches]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Combining case branches: optimistic one-shot-ness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When combining the ArityTypes for two case branches (with andArityType)+and both ArityTypes have ATLamInfo, then we just combine their+expensive-ness and one-shot info. The tricky point is when we have+ case x of True -> \x{one-shot). blah1+ Fale -> \y. blah2 +Since one-shot-ness is about the /consumer/ not the /producer/, we+optimistically assume that if either branch is one-shot, 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.++Hence the call to `bestOneShot` in `andArityType`.++Note [Combining case branches: andWithTail]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When combining the ArityTypes for two case branches (with andArityType)+and one side or the other has run out of ATLamInfo; then we get+into `andWithTail`.++* If one branch is guaranteed bottom (isDeadEndDiv), we just take+ the other; see Note [ABot branches: max arity wins]++* Otherwise, if pedantic-bottoms is on, we just have to return+ AT [] topDiv. E.g. if we have+ f x z = case x of True -> \y. blah+ False -> z+ then we can't eta-expand, because that would change the behaviour+ of (f False bottom().++* But if pedantic-bottoms is not on, we allow ourselves to push+ `z` under a lambda (much as we allow ourselves to put the `case x`+ under a lambda). However we know nothing about the expensiveness+ or one-shot-ness of `z`, so we'd better assume it looks like+ (Expensive, NoOneShotInfo) all the way. Remembering+ Note [Combining case branches: optimistic one-shot-ness],+ we just add work to ever ATLamInfo, keeping the one-shot-ness.++Here's an example:+ 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.)+ 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.@@ -873,22 +1006,21 @@ = AE { ae_mode :: !AnalysisMode -- ^ The analysis mode. See 'AnalysisMode'.- , ae_joins :: !IdSet- -- ^ In-scope join points. See Note [Eta-expansion and join points]- -- INVARIANT: Disjoint with the domain of 'am_sigs' (if present). } -- | The @ArityEnv@ used by 'exprBotStrictness_maybe'. Pedantic about bottoms -- and no application is ever considered cheap. botStrictnessArityEnv :: ArityEnv-botStrictnessArityEnv = AE { ae_mode = BotStrictness, ae_joins = emptyVarSet }+botStrictnessArityEnv = AE { ae_mode = BotStrictness } +{- -- | The @ArityEnv@ used by 'exprEtaExpandArity'. etaExpandArityEnv :: DynFlags -> ArityEnv etaExpandArityEnv dflags = AE { ae_mode = EtaExpandArity { am_ped_bot = gopt Opt_PedanticBottoms dflags , am_dicts_cheap = gopt Opt_DictsCheap dflags } , ae_joins = emptyVarSet }+-} -- | The @ArityEnv@ used by 'findRhsArity'. findRhsArityEnv :: DynFlags -> ArityEnv@@ -896,8 +1028,12 @@ = AE { ae_mode = FindRhsArity { am_ped_bot = gopt Opt_PedanticBottoms dflags , am_dicts_cheap = gopt Opt_DictsCheap dflags , am_sigs = emptyVarEnv }- , ae_joins = emptyVarSet }+ } +isFindRhsArity :: ArityEnv -> Bool+isFindRhsArity (AE { ae_mode = FindRhsArity {} }) = True+isFindRhsArity _ = False+ -- First some internal functions in snake_case for deleting in certain VarEnvs -- of the ArityType. Don't call these; call delInScope* instead! @@ -915,32 +1051,17 @@ del_sig_env_list ids = modifySigEnv (\sigs -> delVarEnvList sigs ids) {-# INLINE del_sig_env_list #-} -del_join_env :: JoinId -> ArityEnv -> ArityEnv -- internal!-del_join_env id env@(AE { ae_joins = joins })- = env { ae_joins = delVarSet joins id }-{-# INLINE del_join_env #-}--del_join_env_list :: [JoinId] -> ArityEnv -> ArityEnv -- internal!-del_join_env_list ids env@(AE { ae_joins = joins })- = env { ae_joins = delVarSetList joins ids }-{-# INLINE del_join_env_list #-}- -- end of internal deletion functions -extendJoinEnv :: ArityEnv -> [JoinId] -> ArityEnv-extendJoinEnv env@(AE { ae_joins = joins }) join_ids- = del_sig_env_list join_ids- $ env { ae_joins = joins `extendVarSetList` join_ids }- extendSigEnv :: ArityEnv -> Id -> ArityType -> ArityEnv extendSigEnv env id ar_ty- = del_join_env id (modifySigEnv (\sigs -> extendVarEnv sigs id ar_ty) env)+ = modifySigEnv (\sigs -> extendVarEnv sigs id ar_ty) env delInScope :: ArityEnv -> Id -> ArityEnv-delInScope env id = del_join_env id $ del_sig_env id env+delInScope env id = del_sig_env id env delInScopeList :: ArityEnv -> [Id] -> ArityEnv-delInScopeList env ids = del_join_env_list ids $ del_sig_env_list ids env+delInScopeList env ids = del_sig_env_list ids env lookupSigEnv :: ArityEnv -> Id -> Maybe ArityType lookupSigEnv AE{ ae_mode = mode } id = case mode of@@ -985,8 +1106,11 @@ myIsCheapApp sigs fn n_val_args = case lookupVarEnv sigs fn of -- Nothing means not a local function, fall back to regular -- 'GHC.Core.Utils.isCheapApp'- Nothing -> isCheapApp fn n_val_args- -- @Just at@ means local function with @at@ as current ArityType.+ Nothing -> isCheapApp fn n_val_args++ -- `Just at` means local function with `at` as current SafeArityType.+ -- NB the SafeArityType bit: that means we can ignore the cost flags+ -- in 'lams', and just consider the length -- Roughly approximate what 'isCheapApp' is doing. Just (AT oss div) | isDeadEndDiv div -> True -- See Note [isCheapApp: bottoming functions] in GHC.Core.Utils@@ -994,7 +1118,10 @@ | otherwise -> False -----------------arityType :: ArityEnv -> CoreExpr -> ArityType+arityType :: HasDebugCallStack => ArityEnv -> CoreExpr -> ArityType+-- Precondition: all the free join points of the expression+-- are bound by the ArityEnv+-- See Note [No free join points in arityType] arityType env (Cast e co) = minWithArity (arityType env e) co_arity -- See Note [Arity trimming]@@ -1006,12 +1133,13 @@ -- #5441 is a nice demo arityType env (Var v)- | v `elemVarSet` ae_joins env- = botArityType -- See Note [Eta-expansion and join points] | Just at <- lookupSigEnv env v -- Local binding = at | otherwise- = idArityType v+ = assertPpr (not (isFindRhsArity env && isJoinId v)) (ppr v) $+ -- All join-point should be in the ae_sigs+ -- See Note [No free join points in arityType]+ idArityType v -- Lambdas; increase arity arityType env (Lam x e)@@ -1048,32 +1176,11 @@ where env' = delInScope env bndr arity_type_alt (Alt _con bndrs rhs) = arityType (delInScopeList env' bndrs) rhs- alts_type = foldr1 andArityType (map arity_type_alt alts)--arityType env (Let (NonRec j rhs) body)- | Just join_arity <- isJoinId_maybe j- , (_, rhs_body) <- collectNBinders join_arity rhs- = -- See Note [Eta-expansion and join points]- andArityType (arityType env rhs_body)- (arityType env' body)- where- env' = extendJoinEnv env [j]--arityType env (Let (Rec pairs) body)- | ((j,_):_) <- pairs- , isJoinId j- = -- See Note [Eta-expansion and join points]- foldr (andArityType . do_one) (arityType env' body) pairs- where- env' = extendJoinEnv env (map fst pairs)- do_one (j,rhs)- | Just arity <- isJoinId_maybe j- = arityType env' $ snd $ collectNBinders arity rhs- | otherwise- = pprPanic "arityType:joinrec" (ppr pairs)+ alts_type = foldr1 (andArityType env) (map arity_type_alt alts) arityType env (Let (NonRec b r) e)- = floatIn cheap_rhs (arityType env' e)+ = -- See Note [arityType for let-bindings]+ floatIn cheap_rhs (arityType env' e) where cheap_rhs = myExprIsCheap env r (Just (idType b)) env' = extendSigEnv env b (arityType env r)@@ -1081,18 +1188,77 @@ arityType env (Let (Rec prs) e) = floatIn (all is_cheap prs) (arityType env' e) where- env' = delInScopeList env (map fst prs) is_cheap (b,e) = myExprIsCheap env' e (Just (idType b))+ env' = foldl extend_rec env prs+ extend_rec :: ArityEnv -> (Id,CoreExpr) -> ArityEnv+ extend_rec env (b,e) = extendSigEnv env b $+ mkManifestArityType bndrs body+ where+ (bndrs, body) = collectBinders e+ -- We can't call arityType on the RHS, because it might mention+ -- join points bound in this very letrec, and we don't want to+ -- do a fixpoint calculation here. So we make do with the+ -- manifest arity arityType env (Tick t e) | not (tickishIsCode t) = arityType env e arityType _ _ = topArityType -{- Note [Eta-expansion and join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this (#18328) +{- Note [No free join points in arityType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we call arityType on this expression (EX1)+ \x . case x of True -> \y. e+ False -> $j 3+where $j is a join point. It really makes no sense to talk of the arity+of this expression, because it has a free join point. In particular, we+can't eta-expand the expression because we'd have do the same thing to the+binding of $j, and we can't see that binding.++If we had (EX2)+ \x. join $j y = blah+ case x of True -> \y. e+ False -> $j 3+then it would make perfect sense: we can determine $j's ArityType, and+propagate it to the usage site as usual.++But how can we get (EX1)? It doesn't make much sense, because $j can't+be a join point under the \x anyway. So we make it a precondition of+arityType that the argument has no free join-point Ids. (This is checked+with an assesrt in the Var case of arityType.)++BUT the invariant risks being invalidated by one very narrow special case: runRW#+ join $j y = blah+ runRW# (\s. case x of True -> \y. e+ False -> $j x)++We have special magic in OccurAnal, and Simplify to allow continuations to+move into the body of a runRW# call.++So we are careful never to attempt to eta-expand the (\s.blah) in the+argument to runRW#, at least not when there is a literal lambda there,+so that OccurAnal has seen it and allowed join points bound outside.+See Note [No eta-expansion in runRW#] in GHC.Core.Opt.Simplify.Iteration.++Note [arityType for let-bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For non-recursive let-bindings, we just get the arityType of the RHS,+and extend the environment. That works nicely for things like this+(#18793):+ go = \ ds. case ds_a2CF of {+ [] -> id+ : y ys -> case y of { GHC.Types.I# x ->+ let acc = go ys in+ case x ># 42# of {+ __DEFAULT -> acc+ 1# -> \x1. acc (negate x2)++Here we want to get a good arity for `acc`, based on the ArityType+of `go`.++All this is particularly important for join points. Consider this (#18328)+ f x = join j y = case y of True -> \a. blah False -> \b. blah@@ -1104,42 +1270,64 @@ and suppose the join point is too big to inline. Now, what is the arity of f? If we inlined the join point, we'd definitely say "arity 2" because we are prepared to push case-scrutinisation inside a-lambda. But currently the join point totally messes all that up,-because (thought of as a vanilla let-binding) the arity pinned on 'j'-is just 1.+lambda. It's important that we extend the envt with j's ArityType,+so that we can use that information in the A/C branch of the case. -Why don't we eta-expand j? Because of-Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils+For /recursive/ bindings it's more difficult, to call arityType,+because we don't have an ArityType to put in the envt for the+recursively bound Ids. So for non-join-point bindings we satisfy+ourselves with mkManifestArityType. Typically we'll have eta-expanded+the binding (based on an earlier fixpoint calculation in+findRhsArity), so the manifest arity is good. -Even if we don't eta-expand j, why is its arity only 1?-See invariant 2b in Note [Invariants on join points] in GHC.Core.+But for /recursive join points/ things are not so good.+See Note [Arity type for recursive join bindings] -So we do this:+See Note [Arity type for recursive join bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+ f x = joinrec j 0 = \ a b c -> (a,x,b)+ j n = j (n-1)+ in j 20 -* Treat the RHS of a join-point binding, /after/ stripping off- join-arity lambda-binders, as very like the body of the let.- More precisely, do andArityType with the arityType from the- body of the let.+Obviously `f` should get arity 4. But the manifest arity of `j`+is 1. Remember, we don't eta-expand join points; see+GHC.Core.Opt.Simplify.Utils Note [Do not eta-expand join points].+And the ArityInfo on `j` will be just 1 too; see GHC.Core+Note [Invariants on join points], item (2b). So using+Note [ArityType for let-bindings] won't work well. -* Dually, when we come to a /call/ of a join point, just no-op- by returning ABot, the bottom element of ArityType,- which so that: bot `andArityType` x = x+We could do a fixpoint iteration, but that's a heavy hammer+to use in arityType. So we take advantage of it being a join+point: -* This works if the join point is bound in the expression we are- taking the arityType of. But if it's bound further out, it makes- no sense to say that (say) the arityType of (j False) is ABot.- Bad things happen. So we keep track of the in-scope join-point Ids- in ae_join.+* Extend the ArityEnv to bind each of the recursive binders+ (all join points) to `botArityType`. This means that any+ jump to the join point will return botArityType, which is+ unit for `andArityType`:+ botAritType `andArityType` at = at+ So it's almost as if those "jump" branches didn't exist. -This will make f, above, have arity 2. Then, we'll eta-expand it thus:+* In this extended env, find the ArityType of each of the RHS, after+ stripping off the join-point binders. - f x eta = (join j y = ... in case x of ...) eta+* Use andArityType to combine all these RHS ArityTypes. -and the Simplify will automatically push that application of eta into-the join points.+* Find the ArityType of the body, also in this strange extended+ environment -An alternative (roughly equivalent) idea would be to carry an-environment mapping let-bound Ids to their ArityType.+* And combine that into the result with andArityType.++In our example, the jump (j 20) will yield Bot, as will the jump+(j (n-1)). We'll 'and' those the ArityType of (\abc. blah). Good!++In effect we are treating the RHSs as alternative bodies (like+in a case), and ignoring all jumps. In this way we don't need+to take a fixpoint. Tricky!++NB: we treat /non-recursive/ join points in the same way, but+actually it works fine to treat them uniformly with normal+let-bindings, and that takes less code. -} idArityType :: Id -> ArityType
GHC/Core/Opt/CprAnal.hs view
@@ -398,8 +398,10 @@ where init_sig id -- See Note [CPR for data structures]- | isDataStructure id = topCprSig- | otherwise = mkCprSig 0 botCpr+ -- Don't set the sig to bottom in this case, because cprAnalBind won't+ -- update it to something reasonable. Result: Assertion error in WW+ | isDataStructure id || isDFunId id = topCprSig+ | otherwise = mkCprSig 0 botCpr -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal orig_virgin = ae_virgin orig_env init_pairs | orig_virgin = [(setIdCprSig id (init_sig id), rhs) | (id, rhs) <- orig_pairs ]@@ -464,10 +466,10 @@ | isDFunId id -- Never give DFuns the CPR property; we'll never save allocs. = (id, rhs, extendSigEnv env id topCprSig) -- See Note [CPR for data structures]- | isDataStructure id- = (id, rhs, env) -- Data structure => no code => no need to analyse rhs+ | isDataStructure id -- Data structure => no code => no need to analyse rhs+ = (id, rhs, env) | otherwise- = (id', rhs', env')+ = (id `setIdCprSig` sig', rhs', env') where (rhs_ty, rhs') = cprAnal env rhs -- possibly trim thunk CPR info@@ -481,7 +483,6 @@ -- See Note [The OPAQUE pragma and avoiding the reboxing of results] sig' | isOpaquePragma (idInlinePragma id) = topCprSig | otherwise = sig- id' = setIdCprSig id sig' env' = extendSigEnv env id sig' -- See Note [CPR for thunks]
GHC/Core/Opt/Simplify.hs view
@@ -64,6 +64,7 @@ import GHC.Data.Maybe ( isNothing, orElse ) import GHC.Data.FastString import GHC.Unit.Module ( moduleName, pprModuleName )+import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain@@ -256,9 +257,11 @@ -> [(InId, InExpr)] -> SimplM (SimplFloats, SimplEnv) simplRecBind env0 bind_cxt pairs0- = do { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0- ; (rec_floats, env1) <- go env_with_info triples- ; return (mkRecFloats rec_floats, env1) }+ = do { (env1, triples) <- mapAccumLM add_rules env0 pairs0+ ; let new_bndrs = map sndOf3 triples+ ; (rec_floats, env2) <- enterRecGroupRHSs env1 new_bndrs $ \env ->+ go env triples+ ; return (mkRecFloats rec_floats, env2) } where add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr)) -- Add the (substituted) rules to the binder@@ -2141,19 +2144,32 @@ (ApplyToVal { sc_arg = arg, sc_env = arg_se , sc_cont = cont, sc_hole_ty = fun_ty }) | fun_id `hasKey` runRWKey- , not (contIsStop cont) -- Don't fiddle around if the continuation is boring , [ TyArg {}, TyArg {} ] <- rev_args- = do { s <- newId (fsLit "s") Many realWorldStatePrimTy- ; let (m,_,_) = splitFunTy fun_ty- env' = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s]+ -- Do this even if (contIsStop cont)+ -- See Note [No eta-expansion in runRW#]+ = do { let arg_env = arg_se `setInScopeFromE` env ty' = contResultType cont- cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s- , sc_env = env', sc_cont = cont- , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' }- -- cont' applies to s, then K- ; body' <- simplExprC env' arg cont'- ; let arg' = Lam s body'- rr' = getRuntimeRep ty'++ -- If the argument is a literal lambda already, take a short cut+ -- This isn't just efficiency; if we don't do this we get a beta-redex+ -- every time, so the simplifier keeps doing more iterations.+ ; arg' <- case arg of+ Lam s body -> do { (env', s') <- simplBinder arg_env s+ ; body' <- simplExprC env' body cont+ ; return (Lam s' body') }+ -- Important: do not try to eta-expand this lambda+ -- See Note [No eta-expansion in runRW#]+ _ -> do { s' <- newId (fsLit "s") Many realWorldStatePrimTy+ ; let (m,_,_) = splitFunTy fun_ty+ env' = arg_env `addNewInScopeIds` [s']+ cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s'+ , sc_env = env', sc_cont = cont+ , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' }+ -- cont' applies to s', then K+ ; body' <- simplExprC env' arg cont'+ ; return (Lam s' body') }++ ; let rr' = getRuntimeRep ty' call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg ty', arg'] ; return (emptyFloats env, call') } @@ -2260,6 +2276,19 @@ discard the entire application and replace it with (error "foo"). Getting all this at once is TOO HARD! +Note [No eta-expansion in runRW#]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we see `runRW# (\s. blah)` we must not attempt to eta-expand that+lambda. Why not? Because+* `blah` can mention join points bound outside the runRW#+* eta-expansion uses arityType, and+* `arityType` cannot cope with free join Ids:++So the simplifier spots the literal lambda, and simplifies inside it.+It's a very special lambda, because it is the one the OccAnal spots and+allows join points bound /outside/ to be called /inside/.++See Note [No free join points in arityType] in GHC.Core.Opt.Arity ************************************************************************ * *
GHC/Core/Opt/Simplify/Env.hs view
@@ -17,7 +17,7 @@ zapSubstEnv, setSubstEnv, bumpCaseDepth, getInScope, setInScopeFromE, setInScopeFromF, setInScopeSet, modifyInScope, addNewInScopeIds,- getSimplRules,+ getSimplRules, enterRecGroupRHSs, -- * Substitution results SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope,@@ -55,6 +55,7 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Data.OrdList+import GHC.Data.Graph.UnVar import GHC.Types.Id as Id import GHC.Core.Make ( mkWildValBinder ) import GHC.Driver.Session ( DynFlags )@@ -96,6 +97,10 @@ , seCvSubst :: CvSubstEnv -- InCoVar |--> OutCoercion , seIdSubst :: SimplIdSubst -- InId |--> OutExpr + -- | Fast OutVarSet tracking which recursive RHSs we are analysing.+ -- See Note [Eta reduction in recursive RHSs] in GHC.Core.Opt.Arity.+ , seRecIds :: !UnVarSet+ ----------- Dynamic part of the environment ----------- -- Dynamic in the sense of describing the setup where -- the expression finally ends up@@ -286,6 +291,7 @@ , seTvSubst = emptyVarEnv , seCvSubst = emptyVarEnv , seIdSubst = emptyVarEnv+ , seRecIds = emptyUnVarSet , seCaseDepth = 0 } -- The top level "enclosing CC" is "SUBSUMED". @@ -391,6 +397,13 @@ modifyInScope env@(SimplEnv {seInScope = in_scope}) v = env {seInScope = extendInScopeSet in_scope v} +enterRecGroupRHSs :: SimplEnv -> [OutBndr] -> (SimplEnv -> SimplM (r, SimplEnv))+ -> SimplM (r, SimplEnv)+enterRecGroupRHSs env bndrs k = do+ --pprTraceM "enterRecGroupRHSs" (ppr bndrs)+ (r, env'') <- k env{seRecIds = extendUnVarSetList bndrs (seRecIds env)}+ return (r, env''{seRecIds = seRecIds env})+ {- Note [Setting the right in-scope set] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -886,31 +899,18 @@ Note [Arity robustness] ~~~~~~~~~~~~~~~~~~~~~~~ We *do* transfer the arity from the in_id of a let binding to the-out_id. This is important, so that the arity of an Id is visible in-its own RHS. For example:- f = \x. ....g (\y. f y)....-We can eta-reduce the arg to g, because f is a value. But that-needs to be visible.--This interacts with the 'state hack' too:- f :: Bool -> IO Int- f = \x. case x of- True -> f y- False -> \s -> ...-Can we eta-expand f? Only if we see that f has arity 1, and then we-take advantage of the 'state hack' on the result of-(f y) :: State# -> (State#, Int) to expand the arity one more.--There is a disadvantage though. Making the arity visible in the RHS-allows us to eta-reduce- f = \x -> f x-to- f = f-which technically is not sound. This is very much a corner case, so-I'm not worried about it. Another idea is to ensure that f's arity-never decreases; its arity started as 1, and we should never eta-reduce-below that.+out_id so that its arity is visible in its RHS. Examples: + * f = \x y. let g = \p q. f (p+q) in Just (...g..g...)+ Here we want to give `g` arity 3 and eta-expand. `findRhsArity` will have a+ hard time figuring that out when `f` only has arity 0 in its own RHS.+ * f = \x y. ....(f `seq` blah)....+ We want to drop the seq.+ * f = \x. g (\y. f y)+ You'd think we could eta-reduce `\y. f y` to `f` here. And indeed, that is true.+ Unfortunately, it is not sound in general to eta-reduce in f's RHS.+ Example: `f = \x. f x`. See Note [Eta reduction in recursive RHSs] for how+ we prevent that. Note [Robust OccInfo] ~~~~~~~~~~~~~~~~~~~~~
GHC/Core/Opt/Simplify/Utils.hs view
@@ -1610,6 +1610,7 @@ ; mkLam' dflags bndrs body } where mode = getMode env+ rec_ids = seRecIds env mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr mkLam' dflags bndrs body@(Lam {})@@ -1633,7 +1634,7 @@ mkLam' dflags bndrs body | gopt Opt_DoEtaReduction dflags- , Just etad_lam <- {-# SCC "tryee" #-} tryEtaReduce bndrs body+ , Just etad_lam <- {-# SCC "tryee" #-} tryEtaReduce rec_ids bndrs body = do { tick (EtaReduction (head bndrs)) ; return etad_lam } @@ -1731,9 +1732,7 @@ tryEtaExpandRhs env bndr rhs | Just join_arity <- isJoinId_maybe bndr = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs- oss = [idOneShotInfo id | id <- join_bndrs, isId id]- arity_type | exprIsDeadEnd join_body = mkBotArityType oss- | otherwise = mkTopArityType oss+ arity_type = mkManifestArityType join_bndrs join_body ; return (arity_type, rhs) } -- Note [Do not eta-expand join points] -- But do return the correct arity and bottom-ness, because
GHC/Core/Opt/SpecConstr.hs view
@@ -1732,14 +1732,6 @@ -- changes (#4012). rule_name = mkFastString ("SC:" ++ occNameString fn_occ ++ show rule_number) spec_name = mkInternalName spec_uniq spec_occ fn_loc--- ; pprTrace "spec_one {" (vcat [ text "function:" <+> ppr fn <+> ppr (idUnique fn)--- , text "sc_count:" <+> ppr (sc_count env)--- , text "pats:" <+> ppr pats--- , text "-->" <+> ppr spec_name--- , text "bndrs" <+> ppr arg_bndrs--- , text "body" <+> ppr body--- , text "how_bound" <+> ppr (sc_how_bound env) ]) $--- return () -- Specialise the body -- ; pprTraceM "body_subst_for" $ ppr (spec_occ) $$ ppr (sc_subst body_env)@@ -1754,9 +1746,10 @@ = calcSpecInfo fn call_pat extra_bndrs -- Annotate the variables with the strictness information from -- the function (see Note [Strictness information in worker binders])-+ add_void_arg = needsVoidWorkerArg fn arg_bndrs spec_lam_args1 (spec_lam_args, spec_call_args, spec_arity, spec_join_arity)- | needsVoidWorkerArg fn arg_bndrs spec_lam_args1+ | add_void_arg+ -- See Note [SpecConst needs to add void args first] , (spec_lam_args, spec_call_args, _) <- addVoidWorkerArg spec_lam_args1 [] -- needsVoidWorkerArg: usual w/w hack to avoid generating -- a spec_rhs of unlifted type and no args.@@ -1777,13 +1770,32 @@ -- Conditionally use result of new worker-wrapper transform spec_rhs = mkLams spec_lam_args (mkSeqs cbv_args spec_body_ty spec_body)- rule_rhs = mkVarApps (Var spec_id) $- dropTail (length extra_bndrs) spec_call_args+ rule_rhs = mkVarApps (Var spec_id) $+ -- This will give us all the arguments we quantify over+ -- in the rule plus the void argument if present+ -- since `length(qvars) + void + length(extra_bndrs) = length spec_call_args`+ dropTail (length extra_bndrs) spec_call_args inline_act = idInlineActivation fn this_mod = sc_module env rule = mkRule this_mod True {- Auto -} True {- Local -} rule_name inline_act fn_name qvars pats rule_rhs -- See Note [Transfer activation]++ -- ; pprTrace "spec_one {" (vcat [ text "function:" <+> ppr fn <+> ppr (idUnique fn)+ -- , text "sc_count:" <+> ppr (sc_count env)+ -- , text "pats:" <+> ppr pats+ -- , text "call_pat:" <+> ppr call_pat+ -- , text "-->" <+> ppr spec_name+ -- , text "bndrs" <+> ppr arg_bndrs+ -- , text "extra_bndrs" <+> ppr extra_bndrs+ -- , text "spec_lam_args" <+> ppr spec_lam_args+ -- , text "spec_call_args" <+> ppr spec_call_args+ -- , text "rule_rhs" <+> ppr rule_rhs+ -- , text "adds_void_worker_arg" <+> ppr adds_void_worker_arg+ -- , text "body" <+> ppr body+ -- , text "spec_rhs" <+> ppr spec_rhs+ -- , text "how_bound" <+> ppr (sc_how_bound env) ]) $+ -- return () ; return (spec_usg, OS { os_pat = call_pat, os_rule = rule , os_id = spec_id , os_rhs = spec_rhs }) }@@ -2262,9 +2274,14 @@ "SpecConstr: bad covars" (ppr bad_covars $$ ppr call) $ if interesting && isEmptyVarSet bad_covars- then+ then do -- pprTraceM "callToPatsOut" (- -- text "fun" <> ppr fn $$+ -- text "fn:" <+> ppr fn $$+ -- text "args:" <+> ppr args $$+ -- text "in_scope:" <+> ppr in_scope $$+ -- -- text "in_scope:" <+> ppr in_scope $$+ -- text "pat_fvs:" <+> ppr pat_fvs+ -- ) -- ppr (CP { cp_qvars = qvars', cp_args = pats })) >> return (Just (CP { cp_qvars = qvars', cp_args = pats, cp_strict_args = concat cbv_ids })) else return Nothing }
GHC/Core/SimpleOpt.hs view
@@ -52,6 +52,7 @@ import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Data.Maybe ( orElse )+import GHC.Data.Graph.UnVar import Data.List (mapAccumL) import qualified Data.ByteString as BS @@ -193,6 +194,10 @@ , soe_subst :: Subst -- ^ Deals with cloning; includes the InScopeSet++ , soe_rec_ids :: !UnVarSet+ -- ^ Fast OutVarSet tracking which recursive RHSs we are analysing.+ -- See Note [Eta reduction in recursive RHSs] } instance Outputable SimpleOptEnv where@@ -205,6 +210,7 @@ emptyEnv opts = SOE { soe_inl = emptyVarEnv , soe_subst = emptySubst+ , soe_rec_ids = emptyUnVarSet , soe_co_opt_opts = so_co_opts opts , soe_uf_opts = so_uf_opts opts }@@ -219,6 +225,13 @@ env2@(SOE { soe_subst = subst2 }) = env2 { soe_subst = setInScope subst2 (substInScope subst1) } +enterRecGroupRHSs :: SimpleOptEnv -> [OutBndr] -> (SimpleOptEnv -> (SimpleOptEnv, r))+ -> (SimpleOptEnv, r)+enterRecGroupRHSs env bndrs k+ = (env'{soe_rec_ids = soe_rec_ids env}, r)+ where+ (env', r) = k env{soe_rec_ids = extendUnVarSetList bndrs (soe_rec_ids env)}+ --------------- simple_opt_clo :: SimpleOptEnv -> SimpleClo -> OutExpr simple_opt_clo env (e_env, e)@@ -228,6 +241,7 @@ simple_opt_expr env expr = go expr where+ rec_ids = soe_rec_ids env subst = soe_subst env in_scope = substInScope subst in_scope_env = (in_scope, simpleUnfoldingFun)@@ -290,13 +304,16 @@ ---------------------- -- go_lam tries eta reduction+ -- It is quite important that it does so. I tried removing this code and+ -- got a lot of regressions, e.g., +11% ghc/alloc in T18223 and many+ -- run/alloc increases. Presumably RULEs are affected. go_lam env bs' (Lam b e) = go_lam env' (b':bs') e where (env', b') = subst_opt_bndr env b go_lam env bs' e- | Just etad_e <- tryEtaReduce bs e' = etad_e- | otherwise = mkLams bs e'+ | Just etad_e <- tryEtaReduce rec_ids bs e' = etad_e+ | otherwise = mkLams bs e' where bs = reverse bs' e' = simple_opt_expr env e@@ -390,12 +407,13 @@ (env', mb_pr) = simple_bind_pair env b' Nothing (env,r') top_level simple_opt_bind env (Rec prs) top_level- = (env'', res_bind)+ = (env2, res_bind) where res_bind = Just (Rec (reverse rev_prs')) prs' = joinPointBindings_maybe prs `orElse` prs- (env', bndrs') = subst_opt_bndrs env (map fst prs')- (env'', rev_prs') = foldl' do_pr (env', []) (prs' `zip` bndrs')+ (env1, bndrs') = subst_opt_bndrs env (map fst prs')+ (env2, rev_prs') = enterRecGroupRHSs env1 bndrs' $ \env ->+ foldl' do_pr (env, []) (prs' `zip` bndrs') do_pr (env, prs) ((b,r), b') = (env', case mb_pr of Just pr -> pr : prs
GHC/Core/Tidy.hs view
@@ -10,7 +10,7 @@ {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Core.Tidy (- tidyExpr, tidyRules, tidyUnfolding, tidyCbvInfoTop+ tidyExpr, tidyRules, tidyCbvInfoTop, tidyBndrs ) where import GHC.Prelude@@ -345,33 +345,36 @@ `setUnfoldingInfo` new_unf old_unf = realUnfoldingInfo old_info- new_unf | isStableUnfolding old_unf = tidyUnfolding rec_tidy_env old_unf old_unf- | otherwise = trimUnfolding old_unf- -- See Note [Preserve evaluatedness]+ new_unf = tidyNestedUnfolding rec_tidy_env old_unf in ((tidy_env', var_env'), id') } ------------ Unfolding ---------------tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding-tidyUnfolding tidy_env df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) _+tidyNestedUnfolding :: TidyEnv -> Unfolding -> Unfolding+tidyNestedUnfolding _ NoUnfolding = NoUnfolding+tidyNestedUnfolding _ BootUnfolding = BootUnfolding+tidyNestedUnfolding _ (OtherCon {}) = evaldUnfolding++tidyNestedUnfolding tidy_env df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) = df { df_bndrs = bndrs', df_args = map (tidyExpr tidy_env') args } where (tidy_env', bndrs') = tidyBndrs tidy_env bndrs -tidyUnfolding tidy_env- unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })- unf_from_rhs+tidyNestedUnfolding tidy_env+ unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src, uf_is_value = is_value }) | isStableSource src = seqIt $ unf { uf_tmpl = tidyExpr tidy_env unf_rhs } -- Preserves OccInfo- -- This seqIt avoids a space leak: otherwise the uf_is_value,- -- uf_is_conlike, ... fields may retain a reference to the- -- pre-tidied expression forever (GHC.CoreToIface doesn't look at them)+ -- This seqIt avoids a space leak: otherwise the uf_is_value,+ -- uf_is_conlike, ... fields may retain a reference to the+ -- pre-tidied expression forever (GHC.CoreToIface doesn't look at them) - | otherwise- = unf_from_rhs- where seqIt unf = seqUnfolding unf `seq` unf-tidyUnfolding _ unf _ = unf -- NoUnfolding or OtherCon+ -- Discard unstable unfoldings, but see Note [Preserve evaluatedness]+ | is_value = evaldUnfolding+ | otherwise = noUnfolding++ where+ seqIt unf = seqUnfolding unf `seq` unf {- Note [Tidy IdInfo]
GHC/Core/Utils.hs view
@@ -26,8 +26,8 @@ exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsDeadEnd, getIdFromTrivialExpr_maybe, exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun,- exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree,- exprIsConLike,+ exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprOkForSpecEval,+ exprIsWorkFree, exprIsConLike, isCheapApp, isExpandableApp, isSaturatedConApp, exprIsTickedString, exprIsTickedString_maybe, exprIsTopLevelBindable,@@ -86,6 +86,7 @@ import GHC.Builtin.Names ( makeStaticName, unsafeEqualityProofIdKey ) import GHC.Builtin.PrimOps +import GHC.Data.Graph.UnVar import GHC.Types.Var import GHC.Types.SrcLoc import GHC.Types.Var.Env@@ -1563,45 +1564,55 @@ -- side effects, and can't diverge or raise an exception. exprOkForSpeculation, exprOkForSideEffects :: CoreExpr -> Bool-exprOkForSpeculation = expr_ok primOpOkForSpeculation-exprOkForSideEffects = expr_ok primOpOkForSideEffects+exprOkForSpeculation = expr_ok fun_always_ok primOpOkForSpeculation+exprOkForSideEffects = expr_ok fun_always_ok primOpOkForSideEffects -expr_ok :: (PrimOp -> Bool) -> CoreExpr -> Bool-expr_ok _ (Lit _) = True-expr_ok _ (Type _) = True-expr_ok _ (Coercion _) = True+fun_always_ok :: Id -> Bool+fun_always_ok _ = True -expr_ok primop_ok (Var v) = app_ok primop_ok v []-expr_ok primop_ok (Cast e _) = expr_ok primop_ok e-expr_ok primop_ok (Lam b e)- | isTyVar b = expr_ok primop_ok e+-- | A special version of 'exprOkForSpeculation' used during+-- Note [Speculative evaluation]. When the predicate arg `fun_ok` returns False+-- for `b`, then `b` is never considered ok-for-spec.+exprOkForSpecEval :: (Id -> Bool) -> CoreExpr -> Bool+exprOkForSpecEval fun_ok = expr_ok fun_ok primOpOkForSpeculation++expr_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool+expr_ok _ _ (Lit _) = True+expr_ok _ _ (Type _) = True+expr_ok _ _ (Coercion _) = True++expr_ok fun_ok primop_ok (Var v) = app_ok fun_ok primop_ok v []+expr_ok fun_ok primop_ok (Cast e _) = expr_ok fun_ok primop_ok e+expr_ok fun_ok primop_ok (Lam b e)+ | isTyVar b = expr_ok fun_ok primop_ok e | otherwise = True -- Tick annotations that *tick* cannot be speculated, because these -- are meant to identify whether or not (and how often) the particular -- source expression was evaluated at runtime.-expr_ok primop_ok (Tick tickish e)+expr_ok fun_ok primop_ok (Tick tickish e) | tickishCounts tickish = False- | otherwise = expr_ok primop_ok e+ | otherwise = expr_ok fun_ok primop_ok e -expr_ok _ (Let {}) = False+expr_ok _ _ (Let {}) = False -- Lets can be stacked deeply, so just give up. -- In any case, the argument of exprOkForSpeculation is -- usually in a strict context, so any lets will have been -- floated away. -expr_ok primop_ok (Case scrut bndr _ alts)+expr_ok fun_ok primop_ok (Case scrut bndr _ alts) = -- See Note [exprOkForSpeculation: case expressions]- expr_ok primop_ok scrut+ expr_ok fun_ok primop_ok scrut && isUnliftedType (idType bndr) -- OK to call isUnliftedType: binders always have a fixed RuntimeRep- && all (\(Alt _ _ rhs) -> expr_ok primop_ok rhs) alts+ && all (\(Alt _ _ rhs) -> expr_ok fun_ok primop_ok rhs) alts && altsAreExhaustive alts -expr_ok primop_ok other_expr+expr_ok fun_ok primop_ok other_expr | (expr, args) <- collectArgs other_expr = case stripTicksTopE (not . tickishCounts) expr of- Var f -> app_ok primop_ok f args+ Var f ->+ app_ok fun_ok primop_ok f args -- 'LitRubbish' is the only literal that can occur in the head of an -- application and will not be matched by the above case (Var /= Lit).@@ -1615,8 +1626,11 @@ _ -> False ------------------------------app_ok :: (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool-app_ok primop_ok fun args+app_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool+app_ok fun_ok primop_ok fun args+ | not (fun_ok fun)+ = False -- This code path is only taken for Note [Speculative evaluation]+ | otherwise = case idDetails fun of DFunId new_type -> not new_type -- DFuns terminate, unless the dict is implemented@@ -1630,7 +1644,7 @@ PrimOpId op | primOpIsDiv op , [arg1, Lit lit] <- args- -> not (isZeroLit lit) && expr_ok primop_ok arg1+ -> not (isZeroLit lit) && expr_ok fun_ok primop_ok arg1 -- Special case for dividing operations that fail -- In general they are NOT ok-for-speculation -- (which primop_ok will catch), but they ARE OK@@ -1679,7 +1693,7 @@ | Just Lifted <- typeLevity_maybe (scaledThing ty) = True -- See Note [Primops with lifted arguments] | otherwise- = expr_ok primop_ok arg+ = expr_ok fun_ok primop_ok arg ----------------------------- altsAreExhaustive :: [Alt b] -> Bool@@ -2415,8 +2429,8 @@ -- When updating this function, make sure to update -- CorePrep.tryEtaReducePrep as well!-tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr-tryEtaReduce bndrs body+tryEtaReduce :: UnVarSet -> [Var] -> CoreExpr -> Maybe CoreExpr+tryEtaReduce rec_ids bndrs body = go (reverse bndrs) body (mkRepReflCo (exprType body)) where incoming_arity = count isId bndrs@@ -2455,14 +2469,15 @@ ok_fun _fun = False ---------------- ok_fun_id fun = -- There are arguments to reduce...- fun_arity fun >= incoming_arity &&- -- ... and the function can be eta reduced to arity 0- canEtaReduceToArity fun 0 0+ ok_fun_id fun =+ -- Don't eta-reduce in fun in its own recursive RHSs+ not (fun `elemUnVarSet` rec_ids) && -- criterion (R)+ -- There are arguments to reduce...+ fun_arity fun >= incoming_arity &&+ -- ... and the function can be eta reduced to arity 0+ canEtaReduceToArity fun 0 0 --------------- fun_arity fun -- See Note [Arity care]- | isLocalId fun- , isStrongLoopBreaker (idOccInfo fun) = 0 | arity > 0 = arity | isEvaldUnfolding (idUnfolding fun) = 1 -- See Note [Eta reduction of an eval'd function]
GHC/CoreToStg/Prep.hs view
@@ -49,6 +49,7 @@ import GHC.Data.OrdList import GHC.Data.FastString import GHC.Data.Pair+import GHC.Data.Graph.UnVar import GHC.Utils.Error import GHC.Utils.Misc@@ -594,7 +595,7 @@ | otherwise = addFloat floats new_float - new_float = mkFloat dmd is_unlifted bndr1 rhs1+ new_float = mkFloat env dmd is_unlifted bndr1 rhs1 ; return (env2, floats1, Nothing) } @@ -608,24 +609,27 @@ cpeBind top_lvl env (Rec pairs) | not (isJoinId (head bndrs))- = do { (env', bndrs1) <- cpCloneBndrs env bndrs+ = do { (env, bndrs1) <- cpCloneBndrs env bndrs+ ; let env' = enterRecGroupRHSs env bndrs1 ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env') bndrs1 rhss ; let (floats_s, rhss1) = unzip stuff all_pairs = foldrOL add_float (bndrs1 `zip` rhss1) (concatFloats floats_s)-+ -- use env below, so that we reset cpe_rec_ids ; return (extendCorePrepEnvList env (bndrs `zip` bndrs1), unitFloat (FloatLet (Rec all_pairs)), Nothing) } | otherwise -- See Note [Join points and floating]- = do { (env', bndrs1) <- cpCloneBndrs env bndrs+ = do { (env, bndrs1) <- cpCloneBndrs env bndrs+ ; let env' = enterRecGroupRHSs env bndrs1 ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss ; let bndrs2 = map fst pairs1- ; return (extendCorePrepEnvList env' (bndrs `zip` bndrs2),+ -- use env below, so that we reset cpe_rec_ids+ ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2), emptyFloats, Just (Rec pairs1)) } where@@ -657,7 +661,7 @@ else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $ -- Note [Silly extra arguments] (do { v <- newVar (idType bndr)- ; let float = mkFloat topDmd False v rhs2+ ; let float = mkFloat env topDmd False v rhs2 ; return ( addFloat floats2 float , cpeEtaExpand arity (Var v)) }) @@ -1464,7 +1468,7 @@ ; if okCpeArg arg2 then do { v <- newVar arg_ty ; let arg3 = cpeEtaExpand (exprArity arg2) arg2- arg_float = mkFloat dmd is_unlifted v arg3+ arg_float = mkFloat env dmd is_unlifted v arg3 ; return (addFloat floats2 arg_float, varToCoreExpr v) } else return (floats2, arg2) }@@ -1669,6 +1673,66 @@ long as the callee might evaluate it. And if it is evaluated on most code paths anyway, we get to turn the unknown eval in the callee into a known call at the call site.++However, we must be very careful not to speculate recursive calls!+Doing so might well change termination behavior.++That comes up in practice for DFuns, which are considered ok-for-spec,+because they always immediately return a constructor.+Not so if you speculate the recursive call, as #20836 shows:++ class Foo m => Foo m where+ runFoo :: m a -> m a+ newtype Trans m a = Trans { runTrans :: m a }+ instance Monad m => Foo (Trans m) where+ runFoo = id++(NB: class Foo m => Foo m` looks weird and needs -XUndecidableSuperClasses. The+example in #20836 is more compelling, but boils down to the same thing.)+This program compiles to the following DFun for the `Trans` instance:++ Rec {+ $fFooTrans+ = \ @m $dMonad -> C:Foo ($fFooTrans $dMonad) (\ @a -> id)+ end Rec }++Note that the DFun immediately terminates and produces a dictionary, just+like DFuns ought to, but it calls itself recursively to produce the `Foo m`+dictionary. But alas, if we treat `$fFooTrans` as always-terminating, so+that we can speculate its calls, and hence use call-by-value, we get:++ $fFooTrans+ = \ @m $dMonad -> case ($fFooTrans $dMonad) of sc ->+ C:Foo sc (\ @a -> id)++and that's an infinite loop!+Note that this bad-ness only happens in `$fFooTrans`'s own RHS. In the+*body* of the letrec, it's absolutely fine to use call-by-value on+`foo ($fFooTrans d)`.++Our solution is this: we track in cpe_rec_ids the set of enclosing+recursively-bound Ids, the RHSs of which we are currently transforming and then+in 'exprOkForSpecEval' (a special entry point to 'exprOkForSpeculation',+basically) we'll say that any binder in this set is not ok-for-spec.++Note if we have a letrec group `Rec { f1 = rhs1; ...; fn = rhsn }`, and we+prep up `rhs1`, we have to include not only `f1`, but all binders of the group+`f1..fn` in this set, otherwise our fix is not robust wrt. mutual recursive+DFuns.++NB: If at some point we decide to have a termination analysis for general+functions (#8655, !1866), we need to take similar precautions for (guarded)+recursive functions:++ repeat x = x : repeat x++Same problem here: As written, repeat evaluates rapidly to WHNF. So `repeat x`+is a cheap call that we are willing to speculate, but *not* in repeat's RHS.+Fortunately, pce_rec_ids already has all the information we need in that case.++The problem is very similar to Note [Eta reduction in recursive RHSs].+Here as well as there it is *unsound* to change the termination properties+of the very function whose termination properties we are exploiting. -} data FloatingBind@@ -1715,8 +1779,8 @@ -- ok-to-speculate unlifted bindings | NotOkToSpec -- Some not-ok-to-speculate unlifted bindings -mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind-mkFloat dmd is_unlifted bndr rhs+mkFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeRhs -> FloatingBind+mkFloat env dmd is_unlifted bndr rhs | is_strict || ok_for_spec -- See Note [Speculative evaluation] , not is_hnf = FloatCase rhs bndr DEFAULT [] ok_for_spec -- Don't make a case for a HNF binding, even if it's strict@@ -1743,7 +1807,8 @@ where is_hnf = exprIsHNF rhs is_strict = isStrUsedDmd dmd- ok_for_spec = exprOkForSpeculation rhs+ ok_for_spec = exprOkForSpecEval (not . is_rec_call) rhs+ is_rec_call = (`elemUnVarSet` cpe_rec_ids env) emptyFloats :: Floats emptyFloats = Floats OkToSpec nilOL@@ -1941,6 +2006,7 @@ , cpe_convertNumLit :: LitNumType -> Integer -> Maybe CoreExpr -- ^ Convert some numeric literals (Integer, Natural) into their -- final Core form+ , cpe_rec_ids :: UnVarSet -- Faster OutIdSet; See Note [Speculative evaluation] } mkInitialCorePrepEnv :: HscEnv -> IO CorePrepEnv@@ -1951,6 +2017,7 @@ , cpe_env = emptyVarEnv , cpe_tyco_env = Nothing , cpe_convertNumLit = convertNumLit+ , cpe_rec_ids = emptyUnVarSet } extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv@@ -1971,6 +2038,10 @@ = case lookupVarEnv (cpe_env cpe) id of Nothing -> Var id Just exp -> exp++enterRecGroupRHSs :: CorePrepEnv -> [OutId] -> CorePrepEnv+enterRecGroupRHSs env grp+ = env { cpe_rec_ids = extendUnVarSetList grp (cpe_rec_ids env) } ------------------------------------------------------------------------------ -- CpeTyCoEnv
GHC/Data/Graph/UnVar.hs view
@@ -17,7 +17,7 @@ module GHC.Data.Graph.UnVar ( UnVarSet , emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets- , extendUnVarSet, delUnVarSet+ , extendUnVarSet, extendUnVarSetList, delUnVarSet, delUnVarSetList , elemUnVarSet, isEmptyUnVarSet , UnVarGraph , emptyUnVarGraph@@ -63,6 +63,9 @@ delUnVarSet :: UnVarSet -> Var -> UnVarSet delUnVarSet (UnVarSet s) v = UnVarSet $ k v `S.delete` s +delUnVarSetList :: UnVarSet -> [Var] -> UnVarSet+delUnVarSetList s vs = s `minusUnVarSet` mkUnVarSet vs+ minusUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet minusUnVarSet (UnVarSet s) (UnVarSet s') = UnVarSet $ s `S.difference` s' @@ -77,6 +80,9 @@ extendUnVarSet :: Var -> UnVarSet -> UnVarSet extendUnVarSet v (UnVarSet s) = UnVarSet $ S.insert (k v) s++extendUnVarSetList :: [Var] -> UnVarSet -> UnVarSet+extendUnVarSetList vs s = s `unionUnVarSet` mkUnVarSet vs unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2)
GHC/Driver/CodeOutput.hs view
@@ -370,26 +370,17 @@ :: Bool -- is Opt_InfoTableMap enabled or not -> Platform -> Module- -> [InfoProvEnt] -> CStub-ipInitCode do_info_table platform this_mod ents+ipInitCode do_info_table platform this_mod | not do_info_table = mempty- | otherwise = initializerCStub platform fn_nm decls body+ | otherwise = initializerCStub platform fn_nm ipe_buffer_decl body where fn_nm = mkInitializerStubLabel this_mod "ip_init"- decls = vcat- $ map emit_ipe_decl ents- ++ [emit_ipe_list ents]- body = text "registerInfoProvList" <> parens local_ipe_list_label <> semi- emit_ipe_decl ipe =- text "extern InfoProvEnt" <+> ipe_lbl <> text "[];"- where ipe_lbl = pprCLabel platform CStyle (mkIPELabel ipe)- local_ipe_list_label = text "local_ipe_" <> ppr this_mod- emit_ipe_list ipes =- text "static InfoProvEnt *" <> local_ipe_list_label <> text "[] ="- <+> braces (vcat $ [ pprCLabel platform CStyle (mkIPELabel ipe) <> comma- | ipe <- ipes- ] ++ [text "NULL"])- <> semi + body = text "registerInfoProvList" <> parens (text "&" <> ipe_buffer_label) <> semi++ ipe_buffer_label = pprCLabel platform CStyle (mkIPELabel this_mod)++ ipe_buffer_decl =+ text "extern IpeBufferListNode" <+> ipe_buffer_label <> text ";"
GHC/Driver/Main.hs view
@@ -1770,7 +1770,7 @@ -- lest we reproduce #11784. mod_name = mkModuleName $ "Cmm$" ++ original_filename cmm_mod = mkHomeModule home_unit mod_name- (cmm, ents) <- ioMsgMaybe+ (cmm, ipe_ents) <- ioMsgMaybe $ do (warns,errs,cmm) <- withTiming logger (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ parseCmmFile dflags cmm_mod home_unit filename@@ -1796,10 +1796,11 @@ Nothing -> cmmToRawCmm logger profile (Stream.yield cmmgroup) Just h -> h dflags Nothing (Stream.yield cmmgroup) - let foreign_stubs _ =- let ip_init = ipInitCode do_info_table platform cmm_mod ents- in NoStubs `appendStubC` ip_init-+ let foreign_stubs _+ | not $ null ipe_ents =+ let ip_init = ipInitCode do_info_table platform cmm_mod+ in NoStubs `appendStubC` ip_init+ | otherwise = NoStubs (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos) <- codeOutput logger tmpfs dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty rawCmms
GHC/Hs/Expr.hs view
@@ -2063,7 +2063,7 @@ type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] = SrcSpanAnnL type instance Anno (FieldLabelStrings (GhcPass p)) = SrcAnn NoEpAnns-type instance Anno (FieldLabelString) = SrcAnn NoEpAnns+type instance Anno (FieldLabelString) = SrcSpanAnnN type instance Anno (DotFieldOcc (GhcPass p)) = SrcAnn NoEpAnns instance (Anno a ~ SrcSpanAnn' (EpAnn an))
GHC/Hs/Syn/Type.hs view
@@ -133,9 +133,9 @@ hsExprType (HsUntypedBracket (HsBracketTc _ ty _wrap _pending) _) = ty hsExprType e@(HsSpliceE{}) = pprPanic "hsExprType: Unexpected HsSpliceE" (ppr e)- -- Typed splices should have been eliminated during zonking, but we- -- can't use `dataConCantHappen` since they are still present before- -- than in the typechecked AST.+ -- Typed splices should have been eliminated during zonking, but we+ -- can't use `dataConCantHappen` since they are still present before+ -- than in the typechecked AST hsExprType (HsProc _ _ lcmd_top) = lhsCmdTopType lcmd_top hsExprType (HsStatic (_, ty) _s) = ty hsExprType (HsPragE _ _ e) = lhsExprType e
GHC/Iface/Ext/Ast.hs view
@@ -744,6 +744,9 @@ RecordCon con_expr _ _ -> computeType con_expr ExprWithTySig _ e _ -> computeLType e HsPragE _ _ e -> computeLType e+ -- By this point all splices are lifted into splice environments so+ -- the remaining HsSpliceE in the syntax tree contain bogus information.+ HsSpliceE {} -> Nothing XExpr (ExpansionExpr (HsExpanded (HsGetField _ _ _) e)) -> Just (hsExprType e) -- for record-dot-syntax XExpr (ExpansionExpr (HsExpanded _ e)) -> computeType e XExpr (HsTick _ e) -> computeLType e@@ -1873,10 +1876,10 @@ toHie _ = pure [] instance ToHie PendingRnSplice where- toHie _ = pure []+ toHie (PendingRnSplice _ _ e) = toHie e instance ToHie PendingTcSplice where- toHie _ = pure []+ toHie (PendingTcSplice _ e) = toHie e instance ToHie (LBooleanFormula (LocatedN Name)) where toHie (L span form) = concatM $ makeNode form (locA span) : case form of
GHC/Iface/Ext/Types.hs view
@@ -781,5 +781,5 @@ | isKnownKeyName name = KnownKeyName (nameUnique name) | isExternalName name = ExternalName (nameModule name) (nameOccName name)- (nameSrcSpan name)- | otherwise = LocalName (nameOccName name) (nameSrcSpan name)+ (removeBufSpan $ nameSrcSpan name)+ | otherwise = LocalName (nameOccName name) (removeBufSpan $ nameSrcSpan name)
GHC/Iface/Tidy.hs view
@@ -24,13 +24,12 @@ import GHC.Core import GHC.Core.Unfold-import GHC.Core.Unfold.Make import GHC.Core.FVs import GHC.Core.Tidy import GHC.Core.Seq (seqBinds)-import GHC.Core.Opt.Arity ( exprArity, exprBotStrictness_maybe )+import GHC.Core.Opt.Arity ( exprArity, exprBotStrictness_maybe, typeArity ) import GHC.Core.InstEnv-import GHC.Core.Type ( tidyTopType )+import GHC.Core.Type ( tidyTopType, Type ) import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Class@@ -74,6 +73,7 @@ import Data.List ( sortBy, mapAccumL ) import qualified Data.Set as S import GHC.Types.CostCentre+import GHC.Core.Opt.OccurAnal (occurAnalyseExpr) {- Constructing the TypeEnv, Instances, Rules from which the@@ -384,8 +384,7 @@ (unfold_env, tidy_occ_env) <- chooseExternalIds opts mod binds implicit_binds imp_rules let (trimmed_binds, trimmed_rules) = findExternalRules opts binds imp_rules unfold_env - let uf_opts = opt_unfolding_opts opts- (tidy_env, tidy_binds) <- tidyTopBinds uf_opts unfold_env boot_exports tidy_occ_env trimmed_binds+ (tidy_env, tidy_binds) <- tidyTopBinds unfold_env boot_exports tidy_occ_env trimmed_binds -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. (spt_entries, mcstub, tidy_binds') <- case opt_static_ptr_opts opts of@@ -1146,60 +1145,49 @@ -- -- * subst_env: A Var->Var mapping that substitutes the new Var for the old -tidyTopBinds :: UnfoldingOpts- -> UnfoldEnv+tidyTopBinds :: UnfoldEnv -> NameSet -> TidyOccEnv -> CoreProgram -> IO (TidyEnv, CoreProgram) -tidyTopBinds uf_opts unfold_env boot_exports init_occ_env binds+tidyTopBinds unfold_env boot_exports init_occ_env binds = do let result = tidy init_env binds seqBinds (snd result) `seq` return result -- This seqBinds avoids a spike in space usage (see #13564) where init_env = (init_occ_env, emptyVarEnv) - tidy = mapAccumL (tidyTopBind uf_opts unfold_env boot_exports)+ tidy = mapAccumL (tidyTopBind unfold_env boot_exports) -------------------------tidyTopBind :: UnfoldingOpts- -> UnfoldEnv+tidyTopBind :: UnfoldEnv -> NameSet -> TidyEnv -> CoreBind -> (TidyEnv, CoreBind) -tidyTopBind uf_opts unfold_env boot_exports+tidyTopBind unfold_env boot_exports (occ_env,subst1) (NonRec bndr rhs) = (tidy_env2, NonRec bndr' rhs') where- Just (name',show_unfold) = lookupVarEnv unfold_env bndr- (bndr', rhs') = tidyTopPair uf_opts show_unfold boot_exports tidy_env2 name' (bndr, rhs)+ (bndr', rhs') = tidyTopPair unfold_env boot_exports tidy_env2 (bndr, rhs) subst2 = extendVarEnv subst1 bndr bndr' tidy_env2 = (occ_env, subst2) -tidyTopBind uf_opts unfold_env boot_exports (occ_env, subst1) (Rec prs)+tidyTopBind unfold_env boot_exports (occ_env, subst1) (Rec prs) = (tidy_env2, Rec prs') where- prs' = [ tidyTopPair uf_opts show_unfold boot_exports tidy_env2 name' (id,rhs)- | (id,rhs) <- prs,- let (name',show_unfold) =- expectJust "tidyTopBind" $ lookupVarEnv unfold_env id- ]-- subst2 = extendVarEnvList subst1 (bndrs `zip` map fst prs')+ prs' = map (tidyTopPair unfold_env boot_exports tidy_env2) prs+ subst2 = extendVarEnvList subst1 (map fst prs `zip` map fst prs') tidy_env2 = (occ_env, subst2)-- bndrs = map fst prs+ -- This is where we "tie the knot": tidy_env2 is fed into tidyTopPair ------------------------------------------------------------tidyTopPair :: UnfoldingOpts- -> Bool -- show unfolding+tidyTopPair :: UnfoldEnv -> NameSet -> TidyEnv -- The TidyEnv is used to tidy the IdInfo -- It is knot-tied: don't look at it!- -> Name -- New name -> (Id, CoreExpr) -- Binder and RHS before tidying -> (Id, CoreExpr) -- This function is the heart of Step 2@@ -1208,18 +1196,19 @@ -- group, a variable late in the group might be mentioned -- in the IdInfo of one early in the group -tidyTopPair uf_opts show_unfold boot_exports rhs_tidy_env name' (bndr, rhs)+tidyTopPair unfold_env boot_exports rhs_tidy_env (bndr, rhs) = -- pprTrace "tidyTop" (ppr name' <+> ppr details <+> ppr rhs) $ (bndr1, rhs1) where+ Just (name',show_unfold) = lookupVarEnv unfold_env bndr !cbv_bndr = tidyCbvInfoTop boot_exports bndr rhs bndr1 = mkGlobalId details name' ty' idinfo' details = idDetails cbv_bndr -- Preserve the IdDetails ty' = tidyTopType (idType cbv_bndr) rhs1 = tidyExpr rhs_tidy_env rhs- idinfo' = tidyTopIdInfo uf_opts rhs_tidy_env name' rhs rhs1 (idInfo cbv_bndr)- show_unfold+ idinfo' = tidyTopIdInfo rhs_tidy_env name' ty'+ rhs rhs1 (idInfo cbv_bndr) show_unfold -- tidyTopIdInfo creates the final IdInfo for top-level -- binders. The delicate piece:@@ -1228,9 +1217,9 @@ -- Indeed, CorePrep must eta expand where necessary to make -- the manifest arity equal to the claimed arity. ---tidyTopIdInfo :: UnfoldingOpts -> TidyEnv -> Name -> CoreExpr -> CoreExpr+tidyTopIdInfo :: TidyEnv -> Name -> Type -> CoreExpr -> CoreExpr -> IdInfo -> Bool -> IdInfo-tidyTopIdInfo uf_opts rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold+tidyTopIdInfo rhs_tidy_env name rhs_ty orig_rhs tidy_rhs idinfo show_unfold | not is_external -- For internal Ids (not externally visible) = vanillaIdInfo -- we only need enough info for code generation -- Arity and strictness info are enough;@@ -1281,13 +1270,17 @@ --------- Unfolding ------------ unf_info = realUnfoldingInfo idinfo- unfold_info- | isCompulsoryUnfolding unf_info || show_unfold- = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs- | otherwise- = minimal_unfold_info- minimal_unfold_info = trimUnfolding unf_info- unf_from_rhs = mkFinalUnfolding uf_opts InlineRhs final_sig tidy_rhs+ !minimal_unfold_info = trimUnfolding unf_info++ !unfold_info | isCompulsoryUnfolding unf_info || show_unfold+ = tidyTopUnfolding rhs_tidy_env tidy_rhs unf_info+ | otherwise+ = minimal_unfold_info++ -- NB: use `orig_rhs` not `tidy_rhs` in this call to mkFinalUnfolding+ -- else you get a black hole (#22122). Reason: mkFinalUnfolding+ -- looks at IdInfo, and that is knot-tied in tidyTopBind (the Rec case)+ -- NB: do *not* expose the worker if show_unfold is off, -- because that means this thing is a loop breaker or -- marked NOINLINE or something like that@@ -1311,4 +1304,54 @@ -- did was to let-bind a non-atomic argument and then float -- it to the top level. So it seems more robust just to -- fix it here.- arity = exprArity orig_rhs+ arity = exprArity orig_rhs `min` (length $ typeArity rhs_ty)+++------------ Unfolding --------------+tidyTopUnfolding :: TidyEnv -> CoreExpr -> Unfolding -> Unfolding+tidyTopUnfolding _ _ NoUnfolding = NoUnfolding+tidyTopUnfolding _ _ BootUnfolding = BootUnfolding+tidyTopUnfolding _ _ (OtherCon {}) = evaldUnfolding++tidyTopUnfolding tidy_env _ df@(DFunUnfolding { df_bndrs = bndrs, df_args = args })+ = df { df_bndrs = bndrs', df_args = map (tidyExpr tidy_env') args }+ where+ (tidy_env', bndrs') = tidyBndrs tidy_env bndrs++tidyTopUnfolding tidy_env tidy_rhs+ unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })+ = -- See Note [tidyTopUnfolding: avoiding black holes]+ unf { uf_tmpl = tidy_unf_rhs }+ where+ tidy_unf_rhs | isStableSource src+ = tidyExpr tidy_env unf_rhs -- Preserves OccInfo in unf_rhs+ | otherwise+ = occurAnalyseExpr tidy_rhs -- Do occ-anal++{- Note [tidyTopUnfolding: avoiding black holes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we are exposing all unfoldings we don't want to tidy the unfolding+twice -- we just want to use the tidied RHS. That tidied RHS itself+contains fully-tidied Ids -- it is knot-tied. So the uf_tmpl for the+unfolding contains stuff we can't look at. Now consider (#22112)+ foo = foo+If we freshly compute the uf_is_value field for foo's unfolding,+we'll call `exprIsValue`, which will look at foo's unfolding!+Whether or not the RHS is a value depends on whether foo is a value...+black hole.++In the Simplifier we deal with this by not giving `foo` an unfolding+in its own RHS. And we could do that here. But it's qite nice+to common everything up to a single Id for foo, used everywhere.++And it's not too hard: simply leave the unfolding undisturbed, except+tidy the uf_tmpl field. Hence tidyTopUnfolding does+ unf { uf_tmpl = tidy_unf_rhs }++Don't mess with uf_is_value, or guidance; in particular don't recompute+them from tidy_unf_rhs.++And (unlike tidyNestedUnfolding) don't deep-seq the new unfolding,+because that'll cause a black hole (I /think/ because occurAnalyseExpr+looks in IdInfo).+-}
GHC/Parser/HaddockLex.hs view
@@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}-{-# LINE 1 "_build/source-dist/ghc-9.4.2-src/ghc-9.4.2/compiler/GHC/Parser/HaddockLex.x" #-}+{-# LINE 1 "_build/source-dist/ghc-9.4.3-src/ghc-9.4.3/compiler/GHC/Parser/HaddockLex.x" #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -funbox-strict-fields #-}@@ -110,7 +110,7 @@ , (0,alex_action_1) ] -{-# LINE 87 "_build/source-dist/ghc-9.4.2-src/ghc-9.4.2/compiler/GHC/Parser/HaddockLex.x" #-}+{-# LINE 87 "_build/source-dist/ghc-9.4.3-src/ghc-9.4.3/compiler/GHC/Parser/HaddockLex.x" #-} data AlexInput = AlexInput { alexInput_position :: !RealSrcLoc , alexInput_string :: !ByteString
GHC/Parser/Lexer.hs view
@@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}-{-# LINE 43 "_build/source-dist/ghc-9.4.2-src/ghc-9.4.2/compiler/GHC/Parser/Lexer.x" #-}+{-# LINE 43 "_build/source-dist/ghc-9.4.3-src/ghc-9.4.3/compiler/GHC/Parser/Lexer.x" #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-}@@ -609,7 +609,7 @@ , (0,alex_action_84) ] -{-# LINE 700 "_build/source-dist/ghc-9.4.2-src/ghc-9.4.2/compiler/GHC/Parser/Lexer.x" #-}+{-# LINE 700 "_build/source-dist/ghc-9.4.3-src/ghc-9.4.3/compiler/GHC/Parser/Lexer.x" #-} -- ----------------------------------------------------------------------------- -- The token type
GHC/Parser/PostProcess.hs view
@@ -2549,7 +2549,7 @@ recFieldToProjUpdate (L l (HsFieldBind anns (L _ (FieldOcc _ (L loc rdr))) arg pun)) = -- The idea here is to convert the label to a singleton [FastString]. let f = occNameFS . rdrNameOcc $ rdr- fl = DotFieldOcc noAnn (L (l2l loc) f) -- AZ: what about the ann?+ fl = DotFieldOcc noAnn (L loc f) lf = locA loc in mkRdrProjUpdate l (L lf [L (l2l loc) fl]) (punnedVar f) pun anns where
+ GHC/StgToCmm/InfoTableProv.hs view
@@ -0,0 +1,131 @@+module GHC.StgToCmm.InfoTableProv (emitIpeBufferListNode) where++import GHC.Prelude+import GHC.Platform+import GHC.Unit.Module+import GHC.Utils.Outputable++import GHC.Cmm.CLabel+import GHC.Cmm.Expr+import GHC.Cmm.Utils+import GHC.StgToCmm.Config+import GHC.StgToCmm.Lit (newByteStringCLit)+import GHC.StgToCmm.Monad+import GHC.StgToCmm.Utils++import GHC.Data.ShortText (ShortText)+import qualified GHC.Data.ShortText as ST++import Data.Bifunctor (first)+import qualified Data.Map.Strict as M+import Control.Monad.Trans.State.Strict+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as BSB+import qualified Data.ByteString.Lazy as BSL++emitIpeBufferListNode :: Module+ -> [InfoProvEnt]+ -> FCode ()+emitIpeBufferListNode _ [] = return ()+emitIpeBufferListNode this_mod ents = do+ cfg <- getStgToCmmConfig+ let ctx = stgToCmmContext cfg+ platform = stgToCmmPlatform cfg++ let (cg_ipes, strtab) = flip runState emptyStringTable $ do+ module_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (ppr this_mod)+ mapM (toCgIPE platform ctx module_name) ents++ let -- Emit the fields of an IpeBufferEntry struct.+ toIpeBufferEntry :: CgInfoProvEnt -> [CmmLit]+ toIpeBufferEntry cg_ipe =+ [ CmmLabel (ipeInfoTablePtr cg_ipe)+ , strtab_offset (ipeTableName cg_ipe)+ , strtab_offset (ipeClosureDesc cg_ipe)+ , strtab_offset (ipeTypeDesc cg_ipe)+ , strtab_offset (ipeLabel cg_ipe)+ , strtab_offset (ipeModuleName cg_ipe)+ , strtab_offset (ipeSrcLoc cg_ipe)+ ]++ int n = mkIntCLit platform n+ int32 n = CmmInt n W32+ strtab_offset (StrTabOffset n) = int32 (fromIntegral n)++ strings <- newByteStringCLit (getStringTableStrings strtab)+ let lits = [ zeroCLit platform -- 'next' field+ , strings -- 'strings' field+ , int $ length cg_ipes -- 'count' field+ ] ++ concatMap toIpeBufferEntry cg_ipes+ emitDataLits (mkIPELabel this_mod) lits++toCgIPE :: Platform -> SDocContext -> StrTabOffset -> InfoProvEnt -> State StringTable CgInfoProvEnt+toCgIPE platform ctx module_name ipe = do+ table_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (pprCLabel platform CStyle (infoTablePtr ipe))+ closure_desc <- lookupStringTable $ ST.pack $ show (infoProvEntClosureType ipe)+ type_desc <- lookupStringTable $ ST.pack $ infoTableType ipe+ let (src_loc_str, label_str) = maybe ("", "") (first (renderWithContext ctx . ppr)) (infoTableProv ipe)+ label <- lookupStringTable $ ST.pack label_str+ src_loc <- lookupStringTable $ ST.pack src_loc_str+ return $ CgInfoProvEnt { ipeInfoTablePtr = infoTablePtr ipe+ , ipeTableName = table_name+ , ipeClosureDesc = closure_desc+ , ipeTypeDesc = type_desc+ , ipeLabel = label+ , ipeModuleName = module_name+ , ipeSrcLoc = src_loc+ }++data CgInfoProvEnt = CgInfoProvEnt+ { ipeInfoTablePtr :: !CLabel+ , ipeTableName :: !StrTabOffset+ , ipeClosureDesc :: !StrTabOffset+ , ipeTypeDesc :: !StrTabOffset+ , ipeLabel :: !StrTabOffset+ , ipeModuleName :: !StrTabOffset+ , ipeSrcLoc :: !StrTabOffset+ }++data StringTable = StringTable { stStrings :: DList ShortText+ , stLength :: !Int+ , stLookup :: !(M.Map ShortText StrTabOffset)+ }++newtype StrTabOffset = StrTabOffset Int++emptyStringTable :: StringTable+emptyStringTable =+ StringTable { stStrings = emptyDList+ , stLength = 0+ , stLookup = M.empty+ }++getStringTableStrings :: StringTable -> BS.ByteString+getStringTableStrings st =+ BSL.toStrict $ BSB.toLazyByteString+ $ foldMap f $ dlistToList (stStrings st)+ where+ f x = BSB.shortByteString (ST.contents x) `mappend` BSB.word8 0++lookupStringTable :: ShortText -> State StringTable StrTabOffset+lookupStringTable str = state $ \st ->+ case M.lookup str (stLookup st) of+ Just off -> (off, st)+ Nothing ->+ let !st' = st { stStrings = stStrings st `snoc` str+ , stLength = stLength st + ST.byteLength str + 1+ , stLookup = M.insert str res (stLookup st)+ }+ res = StrTabOffset (stLength st)+ in (res, st')++newtype DList a = DList ([a] -> [a])++emptyDList :: DList a+emptyDList = DList id++snoc :: DList a -> a -> DList a+snoc (DList f) x = DList (f . (x:))++dlistToList :: DList a -> [a]+dlistToList (DList f) = f []
GHC/StgToCmm/Prof.hs view
@@ -11,7 +11,7 @@ mkCCostCentre, mkCCostCentreStack, -- infoTablePRov- initInfoTableProv, emitInfoTableProv,+ initInfoTableProv, -- Cost-centre Profiling dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,@@ -32,6 +32,7 @@ import GHC.Platform.Profile import GHC.StgToCmm.Closure import GHC.StgToCmm.Config+import GHC.StgToCmm.InfoTableProv import GHC.StgToCmm.Utils import GHC.StgToCmm.Monad import GHC.StgToCmm.Lit@@ -55,7 +56,6 @@ import Control.Monad import Data.Char (ord)-import Data.Bifunctor (first) import GHC.Utils.Monad (whenM) -----------------------------------------------------------------------------@@ -274,9 +274,8 @@ where (ws,ms) = pc_SIZEOF_CostCentreStack (platformConstants platform) `divMod` platformWordSizeInBytes platform -+-- | Emit info-table provenance declarations initInfoTableProv :: [CmmInfoTable] -> InfoTableProvMap -> FCode CStub--- Emit the declarations initInfoTableProv infos itmap = do cfg <- getStgToCmmConfig@@ -284,42 +283,16 @@ info_table = stgToCmmInfoTableMap cfg platform = stgToCmmPlatform cfg this_mod = stgToCmmThisModule cfg- -- Output the actual IPE data- mapM_ emitInfoTableProv ents- -- Create the C stub which initialises the IPE map- return (ipInitCode info_table platform this_mod ents) ---- Info Table Prov stuff-emitInfoTableProv :: InfoProvEnt -> FCode ()-emitInfoTableProv ip = do- { cfg <- getStgToCmmConfig- ; let mod = infoProvModule ip- ctx = stgToCmmContext cfg- platform = stgToCmmPlatform cfg- ; let (src, label) = maybe ("", "") (first (renderWithContext ctx . ppr)) (infoTableProv ip)- mk_string = newByteStringCLit . utf8EncodeString- ; label <- mk_string label- ; modl <- newByteStringCLit (bytesFS $ moduleNameFS- $ moduleName mod)+ case ents of+ [] -> return mempty+ _ -> do+ -- Emit IPE buffer+ emitIpeBufferListNode this_mod ents - ; ty_string <- mk_string (infoTableType ip)- ; loc <- mk_string src- ; table_name <- mk_string (renderWithContext ctx- (pprCLabel platform CStyle (infoTablePtr ip)))- ; closure_type <- mk_string (renderWithContext ctx- (text $ show $ infoProvEntClosureType ip))- ; let- lits = [ CmmLabel (infoTablePtr ip), -- Info table pointer- table_name, -- char *table_name- closure_type, -- char *closure_desc -- Filled in from the InfoTable- ty_string, -- char *ty_string- label, -- char *label,- modl, -- char *module,- loc, -- char *srcloc,- zero platform -- struct _InfoProvEnt *link- ]- ; emitDataLits (mkIPELabel ip) lits- }+ -- Create the C stub which initialises the IPE map+ return (ipInitCode info_table platform this_mod)+ -- --------------------------------------------------------------------------- -- Set the current cost centre stack
GHC/Tc/Deriv/Functor.hs view
@@ -538,8 +538,36 @@ go _ _ = (caseTrivial,False) --- Return all syntactic subterms of ty that contain var somewhere--- These are the things that should appear in instance constraints+-- | Return all syntactic subterms of a 'Type' that are applied to the 'TyVar'+-- argument. This determines what constraints should be inferred for derived+-- 'Functor', 'Foldable', and 'Traversable' instances in "GHC.Tc.Deriv.Infer".+-- For instance, if we have:+--+-- @+-- data Foo a = MkFoo Int a (Maybe a) (Either Int (Maybe a))+-- @+--+-- Then the following would hold:+--+-- * @'deepSubtypesContaining' a Int@ would return @[]@, since @Int@ does not+-- contain the type variable @a@ at all.+--+-- * @'deepSubtypesContaining' a a@ would return @[]@. Although the type @a@+-- contains the type variable @a@, it is not /applied/ to @a@, which is the+-- criterion that 'deepSubtypesContaining' checks for.+--+-- * @'deepSubtypesContaining' a (Maybe a)@ would return @[Maybe]@, as @Maybe@+-- is applied to @a@.+--+-- * @'deepSubtypesContaining' a (Either Int (Maybe a))@ would return+-- @[Either Int, Maybe]@. Both of these types are applied to @a@ through+-- composition.+--+-- As used in "GHC.Tc.Deriv.Infer", the 'Type' argument will always come from+-- 'derivDataConInstArgTys', so it is important that the 'TyVar' comes from+-- 'dataConUnivTyVars' to match. Make sure /not/ to take the 'TyVar' from+-- 'tyConTyVars', as these differ from the 'dataConUnivTyVars' when the data+-- type is a GADT. (See #22167 for what goes wrong if 'tyConTyVars' is used.) deepSubtypesContaining :: TyVar -> Type -> [TcType] deepSubtypesContaining tv = functorLikeTraverse tv
GHC/Tc/Deriv/Generics.hs view
@@ -91,10 +91,25 @@ ************************************************************************ -} +-- | Called by 'GHC.Tc.Deriv.Infer.inferConstraints'; generates a list of+-- types, each of which must be a 'Functor' in order for the 'Generic1'+-- instance to work. For instance, if we have:+--+-- @+-- data Foo a = MkFoo Int a (Maybe a) (Either Int (Maybe a))+-- @+--+-- Then @'get_gen1_constrained_tys' a (f (g a))@ would return @[Either Int]@,+-- as a derived 'Generic1' instance would need to call 'fmap' at that type.+-- Invoking @'get_gen1_constrained_tys' a@ on any of the other fields would+-- return @[]@.+--+-- 'get_gen1_constrained_tys' is very similar in spirit to+-- 'deepSubtypesContaining' in "GHC.Tc.Deriv.Functor". Just like with+-- 'deepSubtypesContaining', it is important that the 'TyVar' argument come+-- from 'dataConUnivTyVars'. (See #22167 for what goes wrong if 'tyConTyVars'+-- is used.) get_gen1_constrained_tys :: TyVar -> Type -> [Type]--- called by GHC.Tc.Deriv.Infer.inferConstraints; generates a list of--- types, each of which must be a Functor in order for the Generic1 instance to--- work. get_gen1_constrained_tys argVar = argTyFold argVar $ ArgTyAlg { ata_rec0 = const [] , ata_par1 = [], ata_rec1 = const []
GHC/Tc/Deriv/Infer.hs view
@@ -176,9 +176,10 @@ -- Constraints arising from the arguments of each constructor con_arg_constraints- :: (CtOrigin -> TypeOrKind- -> Type- -> [(ThetaSpec, Maybe TCvSubst)])+ :: ([TyVar] -> CtOrigin+ -> TypeOrKind+ -> Type+ -> [(ThetaSpec, Maybe TCvSubst)]) -> (ThetaSpec, [TyVar], [TcType], DerivInstTys) con_arg_constraints get_arg_constraints = let -- Constraints from the fields of each data constructor.@@ -193,7 +194,8 @@ , not (isUnliftedType arg_ty) , let orig = DerivOriginDC data_con arg_n wildcard , preds_and_mbSubst- <- get_arg_constraints orig arg_t_or_k arg_ty+ <- get_arg_constraints (dataConUnivTyVars data_con)+ orig arg_t_or_k arg_ty ] -- Stupid constraints from DatatypeContexts. Note that we -- must gather these constraints from the data constructors,@@ -235,21 +237,39 @@ is_functor_like = tcTypeKind inst_ty `tcEqKind` typeToTypeKind || is_generic1 - get_gen1_constraints :: Class -> CtOrigin -> TypeOrKind -> Type- -> [(ThetaSpec, Maybe TCvSubst)]- get_gen1_constraints functor_cls orig t_or_k ty+ get_gen1_constraints ::+ Class+ -> [TyVar] -- The universally quantified type variables for the+ -- data constructor+ -> CtOrigin -> TypeOrKind -> Type+ -> [(ThetaSpec, Maybe TCvSubst)]+ get_gen1_constraints functor_cls dc_univs orig t_or_k ty = mk_functor_like_constraints orig t_or_k functor_cls $- get_gen1_constrained_tys last_tv ty+ get_gen1_constrained_tys last_dc_univ ty+ where+ -- If we are deriving an instance of 'Generic1' and have made+ -- it this far, then there should be at least one universal type+ -- variable, making this use of 'last' safe.+ last_dc_univ = assert (not (null dc_univs)) $+ last dc_univs - get_std_constrained_tys :: CtOrigin -> TypeOrKind -> Type- -> [(ThetaSpec, Maybe TCvSubst)]- get_std_constrained_tys orig t_or_k ty+ get_std_constrained_tys ::+ [TyVar] -- The universally quantified type variables for the+ -- data constructor+ -> CtOrigin -> TypeOrKind -> Type+ -> [(ThetaSpec, Maybe TCvSubst)]+ get_std_constrained_tys dc_univs orig t_or_k ty | is_functor_like = mk_functor_like_constraints orig t_or_k main_cls $- deepSubtypesContaining last_tv ty+ deepSubtypesContaining last_dc_univ ty | otherwise = [( [mk_cls_pred orig t_or_k main_cls ty] , Nothing )]+ where+ -- If 'is_functor_like' holds, then there should be at least one+ -- universal type variable, making this use of 'last' safe.+ last_dc_univ = assert (not (null dc_univs)) $+ last dc_univs mk_functor_like_constraints :: CtOrigin -> TypeOrKind -> Class -> [Type]@@ -277,9 +297,6 @@ , tcUnifyTy ki typeToTypeKind ) - rep_tc_tvs = tyConTyVars rep_tc- last_tv = last rep_tc_tvs- -- Extra Data constraints -- The Data class (only) requires that for -- instance (...) => Data (T t1 t2)@@ -318,7 +335,7 @@ -- Generic1 needs Functor -- See Note [Getting base classes] | is_generic1- -> assert (rep_tc_tvs `lengthExceeds` 0) $+ -> assert (tyConTyVars rep_tc `lengthExceeds` 0) $ -- Generic1 has a single kind variable assert (cls_tys `lengthIs` 1) $ do { functorClass <- lift $ tcLookupClass functorClassName
GHC/Types/Id/Info.hs view
@@ -834,7 +834,7 @@ trimUnfolding :: Unfolding -> Unfolding -- Squash all unfolding info, preserving only evaluated-ness trimUnfolding unf | isEvaldUnfolding unf = evaldUnfolding- | otherwise = noUnfolding+ | otherwise = noUnfolding zapTailCallInfo :: IdInfo -> Maybe IdInfo zapTailCallInfo info
GHC/Types/SrcLoc.hs view
@@ -68,6 +68,7 @@ getBufPos, BufSpan(..), getBufSpan,+ removeBufSpan, -- * Located Located,@@ -397,6 +398,10 @@ | UnhelpfulGenerated | UnhelpfulOther !FastString deriving (Eq, Show)++removeBufSpan :: SrcSpan -> SrcSpan+removeBufSpan (RealSrcSpan s _) = RealSrcSpan s Strict.Nothing+removeBufSpan s = s {- Note [Why Maybe BufPos] ~~~~~~~~~~~~~~~~~~~~~~~~~~
GHC/Utils/Binary.hs view
@@ -1306,19 +1306,6 @@ return (mkRealSrcSpan (mkRealSrcLoc f sl sc) (mkRealSrcLoc f el ec)) -instance Binary BufPos where- put_ bh (BufPos i) = put_ bh i- get bh = BufPos <$> get bh--instance Binary BufSpan where- put_ bh (BufSpan start end) = do- put_ bh start- put_ bh end- get bh = do- start <- get bh- end <- get bh- return (BufSpan start end)- instance Binary UnhelpfulSpanReason where put_ bh r = case r of UnhelpfulNoLocationInfo -> putByte bh 0@@ -1337,10 +1324,11 @@ _ -> UnhelpfulOther <$> get bh instance Binary SrcSpan where- put_ bh (RealSrcSpan ss sb) = do+ put_ bh (RealSrcSpan ss _sb) = do putByte bh 0+ -- BufSpan doesn't ever get serialised because the positions depend+ -- on build location. put_ bh ss- put_ bh sb put_ bh (UnhelpfulSpan s) = do putByte bh 1@@ -1350,8 +1338,7 @@ h <- getByte bh case h of 0 -> do ss <- get bh- sb <- get bh- return (RealSrcSpan ss sb)+ return (RealSrcSpan ss Strict.Nothing) _ -> do s <- get bh return (UnhelpfulSpan s)
Language/Haskell/Syntax/Expr.hs view
@@ -37,6 +37,7 @@ import GHC.Types.Name import GHC.Types.Basic import GHC.Types.Fixity+import GHC.Types.Name.Reader import GHC.Types.SourceText import GHC.Types.SrcLoc import GHC.Unit.Module (ModuleName)@@ -159,8 +160,20 @@ pprFieldLabelStrings (FieldLabelStrings flds) = hcat (punctuate dot (map (ppr . unXRec @p) flds)) -instance Outputable(XRec p FieldLabelString) => Outputable (DotFieldOcc p) where- ppr (DotFieldOcc _ s) = ppr s+pprPrefixFieldLabelStrings :: forall p. (UnXRec p, Outputable (XRec p FieldLabelString))+ => FieldLabelStrings p -> SDoc+pprPrefixFieldLabelStrings (FieldLabelStrings flds) =+ hcat (punctuate dot (map (pprPrefixFieldLabelString . unXRec @p) flds))++pprPrefixFieldLabelString :: forall p. UnXRec p => DotFieldOcc p -> SDoc+pprPrefixFieldLabelString (DotFieldOcc _ s) = (pprPrefixFastString . unXRec @p) s+pprPrefixFieldLabelString XDotFieldOcc{} = text "XDotFieldOcc"++pprPrefixFastString :: FastString -> SDoc+pprPrefixFastString fs = pprPrefixOcc (mkVarUnqual fs)++instance UnXRec p => Outputable (DotFieldOcc p) where+ ppr (DotFieldOcc _ s) = (pprPrefixFastString . unXRec @p) s ppr XDotFieldOcc{} = text "XDotFieldOcc" -- Field projection updates (e.g. @foo.bar.baz = 1@). See Note
ghc.cabal view
@@ -3,7 +3,7 @@ -- ./configure. Make sure you are editing ghc.cabal.in, not ghc.cabal. Name: ghc-Version: 9.4.2+Version: 9.4.3 License: BSD-3-Clause License-File: LICENSE Author: The GHC Team@@ -91,9 +91,9 @@ transformers == 0.5.*, exceptions == 0.10.*, stm,- ghc-boot == 9.4.2,- ghc-heap == 9.4.2,- ghci == 9.4.2+ ghc-boot == 9.4.3,+ ghc-heap == 9.4.3,+ ghci == 9.4.3 if os(windows) Build-Depends: Win32 >= 2.3 && < 2.13@@ -591,6 +591,7 @@ GHC.StgToCmm.Foreign GHC.StgToCmm.Heap GHC.StgToCmm.Hpc+ GHC.StgToCmm.InfoTableProv GHC.StgToCmm.Layout GHC.StgToCmm.Lit GHC.StgToCmm.Monad