ghc-lib-parser 9.4.2.20220822 → 9.4.3.20221104
raw patch · 16 files changed
+607/−185 lines, 16 files
Files
- compiler/GHC/Cmm/CLabel.hs +6/−2
- compiler/GHC/Core.hs +1/−0
- compiler/GHC/Core/Opt/Arity.hs +290/−102
- compiler/GHC/Core/SimpleOpt.hs +23/−5
- compiler/GHC/Core/Tidy.hs +19/−16
- compiler/GHC/Core/Utils.hs +47/−32
- compiler/GHC/Data/Graph/UnVar.hs +187/−0
- compiler/GHC/Hs/Expr.hs +1/−1
- compiler/GHC/Parser/PostProcess.hs +1/−1
- compiler/GHC/Types/Id/Info.hs +1/−1
- compiler/GHC/Types/SrcLoc.hs +5/−0
- compiler/GHC/Utils/Binary.hs +4/−17
- compiler/Language/Haskell/Syntax/Expr.hs +15/−2
- ghc-lib-parser.cabal +2/−1
- ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs +4/−4
- libraries/ghci/GHCi/Message.hs +1/−1
compiler/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 =
compiler/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.
compiler/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
compiler/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
compiler/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]
compiler/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]
+ compiler/GHC/Data/Graph/UnVar.hs view
@@ -0,0 +1,187 @@+{-++Copyright (c) 2014 Joachim Breitner++A data structure for undirected graphs of variables+(or in plain terms: Sets of unordered pairs of numbers)+++This is very specifically tailored for the use in CallArity. In particular it+stores the graph as a union of complete and complete bipartite graph, which+would be very expensive to store as sets of edges or as adjanceny lists.++It does not normalize the graphs. This means that g `unionUnVarGraph` g is+equal to g, but twice as expensive and large.++-}+module GHC.Data.Graph.UnVar+ ( UnVarSet+ , emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets+ , extendUnVarSet, extendUnVarSetList, delUnVarSet, delUnVarSetList+ , elemUnVarSet, isEmptyUnVarSet+ , UnVarGraph+ , emptyUnVarGraph+ , unionUnVarGraph, unionUnVarGraphs+ , completeGraph, completeBipartiteGraph+ , neighbors+ , hasLoopAt+ , delNode+ ) where++import GHC.Prelude++import GHC.Types.Id+import GHC.Types.Var.Env+import GHC.Types.Unique.FM+import GHC.Utils.Outputable+import GHC.Types.Unique++import qualified Data.IntSet as S++-- We need a type for sets of variables (UnVarSet).+-- We do not use VarSet, because for that we need to have the actual variable+-- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet.+-- Therefore, use a IntSet directly (which is likely also a bit more efficient).++-- Set of uniques, i.e. for adjancet nodes+newtype UnVarSet = UnVarSet (S.IntSet)+ deriving Eq++k :: Var -> Int+k v = getKey (getUnique v)++emptyUnVarSet :: UnVarSet+emptyUnVarSet = UnVarSet S.empty++elemUnVarSet :: Var -> UnVarSet -> Bool+elemUnVarSet v (UnVarSet s) = k v `S.member` s+++isEmptyUnVarSet :: UnVarSet -> Bool+isEmptyUnVarSet (UnVarSet s) = S.null s++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'++sizeUnVarSet :: UnVarSet -> Int+sizeUnVarSet (UnVarSet s) = S.size s++mkUnVarSet :: [Var] -> UnVarSet+mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs++varEnvDom :: VarEnv a -> UnVarSet+varEnvDom ae = UnVarSet $ ufmToSet_Directly ae++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)++unionUnVarSets :: [UnVarSet] -> UnVarSet+unionUnVarSets = foldl' (flip unionUnVarSet) emptyUnVarSet++instance Outputable UnVarSet where+ ppr (UnVarSet s) = braces $+ hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s]++data UnVarGraph = CBPG !UnVarSet !UnVarSet -- ^ complete bipartite graph+ | CG !UnVarSet -- ^ complete graph+ | Union UnVarGraph UnVarGraph+ | Del !UnVarSet UnVarGraph++emptyUnVarGraph :: UnVarGraph+emptyUnVarGraph = CG emptyUnVarSet++unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph+{-+Premature optimisation, it seems.+unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])+ | s1 == s3 && s2 == s4+ = pprTrace "unionUnVarGraph fired" empty $+ completeGraph (s1 `unionUnVarSet` s2)+unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])+ | s2 == s3 && s1 == s4+ = pprTrace "unionUnVarGraph fired2" empty $+ completeGraph (s1 `unionUnVarSet` s2)+-}+unionUnVarGraph a b+ | is_null a = b+ | is_null b = a+ | otherwise = Union a b++unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph+unionUnVarGraphs = foldl' unionUnVarGraph emptyUnVarGraph++-- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B }+completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph+completeBipartiteGraph s1 s2 = prune $ CBPG s1 s2++completeGraph :: UnVarSet -> UnVarGraph+completeGraph s = prune $ CG s++-- (v' ∈ neighbors G v) <=> v--v' ∈ G+neighbors :: UnVarGraph -> Var -> UnVarSet+neighbors = go+ where+ go (Del d g) v+ | v `elemUnVarSet` d = emptyUnVarSet+ | otherwise = go g v `minusUnVarSet` d+ go (Union g1 g2) v = go g1 v `unionUnVarSet` go g2 v+ go (CG s) v = if v `elemUnVarSet` s then s else emptyUnVarSet+ go (CBPG s1 s2) v = (if v `elemUnVarSet` s1 then s2 else emptyUnVarSet) `unionUnVarSet`+ (if v `elemUnVarSet` s2 then s1 else emptyUnVarSet)++-- hasLoopAt G v <=> v--v ∈ G+hasLoopAt :: UnVarGraph -> Var -> Bool+hasLoopAt = go+ where+ go (Del d g) v+ | v `elemUnVarSet` d = False+ | otherwise = go g v+ go (Union g1 g2) v = go g1 v || go g2 v+ go (CG s) v = v `elemUnVarSet` s+ go (CBPG s1 s2) v = v `elemUnVarSet` s1 && v `elemUnVarSet` s2++delNode :: UnVarGraph -> Var -> UnVarGraph+delNode (Del d g) v = Del (extendUnVarSet v d) g+delNode g v+ | is_null g = emptyUnVarGraph+ | otherwise = Del (mkUnVarSet [v]) g++-- | Resolves all `Del`, by pushing them in, and simplifies `∅ ∪ … = …`+prune :: UnVarGraph -> UnVarGraph+prune = go emptyUnVarSet+ where+ go :: UnVarSet -> UnVarGraph -> UnVarGraph+ go dels (Del dels' g) = go (dels `unionUnVarSet` dels') g+ go dels (Union g1 g2)+ | is_null g1' = g2'+ | is_null g2' = g1'+ | otherwise = Union g1' g2'+ where+ g1' = go dels g1+ g2' = go dels g2+ go dels (CG s) = CG (s `minusUnVarSet` dels)+ go dels (CBPG s1 s2) = CBPG (s1 `minusUnVarSet` dels) (s2 `minusUnVarSet` dels)++-- | Shallow empty check.+is_null :: UnVarGraph -> Bool+is_null (CBPG s1 s2) = isEmptyUnVarSet s1 || isEmptyUnVarSet s2+is_null (CG s) = isEmptyUnVarSet s+is_null _ = False++instance Outputable UnVarGraph where+ ppr (Del d g) = text "Del" <+> ppr (sizeUnVarSet d) <+> parens (ppr g)+ ppr (Union a b) = text "Union" <+> parens (ppr a) <+> parens (ppr b)+ ppr (CG s) = text "CG" <+> ppr (sizeUnVarSet s)+ ppr (CBPG a b) = text "CBPG" <+> ppr (sizeUnVarSet a) <+> ppr (sizeUnVarSet b)
compiler/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))
compiler/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
compiler/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
compiler/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] ~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/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)
compiler/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-lib-parser.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.0 build-type: Simple name: ghc-lib-parser-version: 9.4.2.20220822+version: 9.4.3.20221104 license: BSD3 license-file: LICENSE category: Development@@ -220,6 +220,7 @@ GHC.Data.FastString.Env GHC.Data.FiniteMap GHC.Data.Graph.Directed+ GHC.Data.Graph.UnVar GHC.Data.IOEnv GHC.Data.List.SetOps GHC.Data.Maybe
ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs view
@@ -3,19 +3,19 @@ import Prelude -- See Note [Why do we import Prelude here?] cProjectGitCommitId :: String-cProjectGitCommitId = "e8a889a7fc670532a3bf883a3e25acba92e6e6e1"+cProjectGitCommitId = "8f8dba0190fe2a3a8b148fecf0dc83a725fb3fd2" cProjectVersion :: String-cProjectVersion = "9.4.2"+cProjectVersion = "9.4.3" cProjectVersionInt :: String cProjectVersionInt = "904" cProjectPatchLevel :: String-cProjectPatchLevel = "2"+cProjectPatchLevel = "3" cProjectPatchLevel1 :: String-cProjectPatchLevel1 = "2"+cProjectPatchLevel1 = "3" cProjectPatchLevel2 :: String cProjectPatchLevel2 = "0"
libraries/ghci/GHCi/Message.hs view
@@ -465,7 +465,7 @@ #define MIN_VERSION_ghc_heap(major1,major2,minor) (\ (major1) < 9 || \ (major1) == 9 && (major2) < 4 || \- (major1) == 9 && (major2) == 4 && (minor) <= 2)+ (major1) == 9 && (major2) == 4 && (minor) <= 3) #endif /* MIN_VERSION_ghc_heap */ #if MIN_VERSION_ghc_heap(8,11,0) instance Binary Heap.StgTSOProfInfo