April 2025 - ghc-commits

[Git][ghc/ghc][wip/andreask/spec_tyfams] Rmoved accidentally committed traces
by Simon Peyton Jones (＠simonpj) 26 Apr '25

26 Apr '25

Simon Peyton Jones pushed to branch wip/andreask/spec_tyfams at Glasgow Haskell Compiler / GHC Commits: 279442ed by Simon Peyton Jones at 2025-04-26T23:07:09+01:00 Rmoved accidentally committed traces and add missing import - - - - - 1 changed file: - compiler/GHC/Core/Opt/Specialise.hs Changes: ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -17,6 +17,7 @@ import GHC.Core.Type hiding( substTy, substCo, extendTvSubst, zapSubst ) -- import GHC.Core.Multiplicity import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith, exprIsConApp_maybe ) import GHC.Core.Predicate +import GHC.Core.Class( classMethods ) import GHC.Core.Coercion( Coercion ) import GHC.Core.Opt.Monad import qualified GHC.Core.Subst as Core @@ -1646,10 +1647,10 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs -- See Note [Inline specialisations] for why we do not -- switch off specialisation for inline functions - = pprTrace "specCalls: some" (vcat - [ text "function" <+> ppr fn - , text "calls:" <+> ppr calls_for_me - , text "subst" <+> ppr (se_subst env) ]) $ + = -- pprTrace "specCalls: some" (vcat + -- [ text "function" <+> ppr fn + -- , text "calls:" <+> ppr calls_for_me + -- , text "subst" <+> ppr (se_subst env) ]) $ foldlM spec_call ([], [], emptyUDs) calls_for_me | otherwise -- No calls or RHS doesn't fit our preconceptions @@ -1705,7 +1706,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs , rule_bndrs, rule_lhs_args , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args - ; when True $ pprTrace "spec_call" (vcat + ; when False $ pprTrace "spec_call" (vcat [ text "fun: " <+> ppr fn , text "call info: " <+> ppr _ci , text "useful: " <+> ppr useful @@ -3034,7 +3035,7 @@ mkCallUDs' :: SpecEnv -> Id -> [OutExpr] -> UsageDetails mkCallUDs' env f args | wantCallsFor env f -- We want it, and... , not (null ci_key) -- this call site has a useful specialisation - = pprTrace "mkCallUDs: keeping" _trace_doc + = -- pprTrace "mkCallUDs: keeping" _trace_doc singleCall env f ci_key | otherwise -- See also Note [Specialisations already covered] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/279442edcad54e8b5b23240c0354c87… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/279442edcad54e8b5b23240c0354c87… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/spec_tyfams] Polishing up from Simon
by Simon Peyton Jones (＠simonpj) 26 Apr '25

26 Apr '25

Simon Peyton Jones pushed to branch wip/andreask/spec_tyfams at Glasgow Haskell Compiler / GHC Commits: 483a939e by Simon Peyton Jones at 2025-04-26T22:51:58+01:00 Polishing up from Simon - - - - - 7 changed files: - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Predicate.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Utils/TcType.hs Changes: ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -26,7 +26,7 @@ import GHC.Core.Make ( mkLitRubbish ) import GHC.Core.Unify ( tcMatchTy ) import GHC.Core.Rules import GHC.Core.Utils ( exprIsTrivial, exprIsTopLevelBindable - , mkCast, exprType + , mkCast, exprType, exprIsHNF , stripTicksTop, mkInScopeSetBndrs ) import GHC.Core.FVs import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList ) @@ -1646,10 +1646,10 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs -- See Note [Inline specialisations] for why we do not -- switch off specialisation for inline functions - = -- pprTrace "specCalls: some" (vcat - -- [ text "function" <+> ppr fn - -- , text "calls:" <+> ppr calls_for_me - -- , text "subst" <+> ppr (se_subst env) ]) $ + = pprTrace "specCalls: some" (vcat + [ text "function" <+> ppr fn + , text "calls:" <+> ppr calls_for_me + , text "subst" <+> ppr (se_subst env) ]) $ foldlM spec_call ([], [], emptyUDs) calls_for_me | otherwise -- No calls or RHS doesn't fit our preconceptions @@ -1705,7 +1705,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs , rule_bndrs, rule_lhs_args , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args - ; when False $ pprTrace "spec_call" (vcat + ; when True $ pprTrace "spec_call" (vcat [ text "fun: " <+> ppr fn , text "call info: " <+> ppr _ci , text "useful: " <+> ppr useful @@ -3034,7 +3034,7 @@ mkCallUDs' :: SpecEnv -> Id -> [OutExpr] -> UsageDetails mkCallUDs' env f args | wantCallsFor env f -- We want it, and... , not (null ci_key) -- this call site has a useful specialisation - = -- pprTrace "mkCallUDs: keeping" _trace_doc + = pprTrace "mkCallUDs: keeping" _trace_doc singleCall env f ci_key | otherwise -- See also Note [Specialisations already covered] @@ -3042,7 +3042,7 @@ mkCallUDs' env f args emptyUDs where - _trace_doc = vcat [ppr f, ppr args, ppr ci_key] + _trace_doc = vcat [ppr f, ppr args, ppr ci_key, ppr (se_subst env)] pis = fst $ splitPiTys $ idType f constrained_tyvars = tyCoVarsOfTypes $ getTheta pis @@ -3116,22 +3116,64 @@ There really is not much point in specialising f wrt the dictionary d, because the code for the specialised f is not improved at all, because d is lambda-bound. We simply get junk specialisations. -What is "interesting"? Just that it has *some* structure. But what about -variables? We look in the variable's /unfolding/. And that means -that we must be careful to ensure that dictionaries have unfoldings, - -* cloneBndrSM discards non-Stable unfoldings -* specBind updates the unfolding after specialisation - See Note [Update unfolding after specialisation] -* bindAuxiliaryDict adds an unfolding for an aux dict - see Note [Specialisation modulo dictionary selectors] -* specCase adds unfoldings for the new bindings it creates - -We accidentally lost accurate tracking of local variables for a long -time, because cloned variables didn't have unfoldings. But makes a -massive difference in a few cases, eg #5113. For nofib as a -whole it's only a small win: 2.2% improvement in allocation for ansi, -1.2% for bspt, but mostly 0.0! Average 0.1% increase in binary size. +What is "interesting"? Our Main Plan is to use `exprIsConApp_maybe` to see +if the argumeng is a dictionary constructor applied to some arguments, in which +case we can clearly specialise. But there are wrinkles: + +(ID1) Note that we look at the argument /term/, not its /type/. Suppose the + argument is + (% d1, d2 %) |> co + where co :: (% Eq [a], Show [a] %) ~ F Int a, and `F` is a type family. + Then its type (F Int a) looks very un-informative, but the term is super + helpful. See #19747 (where missing this point caused a 70x slow down) + and #7785. + +(ID2) Note that the Main Plan works fine for an argument that is a DFun call, + e.g. $fOrdList $dOrdInt + because `exprIsConApp_maybe` cleverly deals with DFunId applications. Good! + +(ID3) For variables, we look in the variable's /unfolding/. And that means + that we must be careful to ensure that dictionaries /have/ unfoldings: + * cloneBndrSM discards non-Stable unfoldings + * specBind updates the unfolding after specialisation + See Note [Update unfolding after specialisation] + * bindAuxiliaryDict adds an unfolding for an aux dict + see Note [Specialisation modulo dictionary selectors] + * specCase adds unfoldings for the new bindings it creates + + We accidentally lost accurate tracking of local variables for a long + time, because cloned variables didn't have unfoldings. But makes a + massive difference in a few cases, eg #5113. For nofib as a + whole it's only a small win: 2.2% improvement in allocation for ansi, + 1.2% for bspt, but mostly 0.0! Average 0.1% increase in binary size. + +(ID4) We must be very careful not to specialise on a "dictionry" that is, or contains + an implicit parameter, because implicit parameters are emphatically not singleton + types. See #25999: + useImplicit :: (?i :: Int) => Int + useImplicit = ?i + 1 + + foo = let ?i = 1 in (useImplicit, let ?i = 2 in useImplicit) + Both calls to `useImplicit` are at type `?i::Int`, but they pass different values. + We must not specialise on implicit parameters! Hence the call to `couldBeIPLike`. + +(ID5) Suppose the argument is (e |> co). Can we rely on `exprIsConApp_maybe` to deal + with the coercion. No! That only works if (co :: C t1 ~ C t2) with the same type + constructor at the top of both sides. But see the example in (ID1), where that + is not true. For thes same reason, we can't rely on `exprIsConApp_maybe` to look + through unfoldings (because there might be a cast inside), hence dealing with + expandable unfoldings in `interestingDict` directly. + +(ID6) The Main Plan says that it's worth specialising if the argument is an application + of a dictionary contructor. But what if the dictionary has no methods? Then we + gain nothing by specialising, unless the /superclasses/ are interesting. A case + in point is constraint tuples (% d1, .., dn %); a constraint N-tuple is a class + with N superclasses and no methods. + +(ID7) A unary (single-method) class is currently represented by (meth |> co). + We will unwrap the cast (see (ID5)) and then want to reply "yes" if the method + has any struture. We use `exprIsHNF` for this. (We plan a new story for unary + classes, see #23109, and this special case will become irrelevant.) Note [Update unfolding after specialisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -3159,6 +3201,7 @@ Consider (#21848) Now `f` turns into: f @a @b (dd :: D a) (ds :: Show b) a b + = let dc :: D a = %p1 dd -- Superclass selection in meth @a dc .... meth @a dc .... @@ -3174,50 +3217,25 @@ in the NonRec case of specBind. (This is too exotic to trouble with the Rec case.) -} --- interestingDict :: CoreExpr -> Type -> Bool interestingDict :: InScopeEnv -> CoreExpr -> Bool --- A dictionary argument is interesting if it has *some* structure, --- see Note [Interesting dictionary arguments] --- NB: "dictionary" arguments include constraints of all sorts, --- including equality constraints; hence the Coercion case --- To make this work, we need to ensure that dictionaries have --- unfoldings in them. -interestingDict env (Cast arg _) +-- See Note [Interesting dictionary arguments] +interestingDict env (Var v) -- See (ID3) and (ID5) + | Just rhs <- expandUnfolding_maybe (idUnfolding v) + = interestingDict env rhs +interestingDict env (Cast arg _) -- See (ID5) = interestingDict env arg -interestingDict env arg +interestingDict env arg -- Main Plan: use exprIsConApp_maybe | Just (_, _, data_con, _tys, args) <- exprIsConApp_maybe env arg , Just cls <- tyConClass_maybe (dataConTyCon data_con) - , (not . isIPLikePred) (exprType arg) - = if isCTupleClass cls + , (not . couldBeIPLike) (exprType arg) -- See (ID4) + = if null (classMethods cls) -- See (ID6) then any (interestingDict env) args else True + | exprIsHNF arg -- See (ID7) + = True | otherwise = False - --- interestingDict arg _arg_ty --- -- No benefit to specalizing for a ~# b I believe --- -- | (isEqPred arg_ty) = False --- -- | --- -- not (typeDeterminesValue arg_ty) = False -- See Note [Type determines value] --- | otherwise = go arg --- where --- go (Var v) = hasSomeUnfolding (idUnfolding v) --- || isDataConWorkId v --- go (Type _) = False --- go (Coercion _) = False --- go (App fn (Type _)) = go fn --- go (App fn (Coercion _)) = go fn --- go (Tick _ a) = go a --- go (Cast e _) = go e --- go (Lit{}) = True --- go (Case{}) = True --- go (Let{}) = True --- go (App{}) = True --- go (Lam{}) = True - - -- go _ = True - thenUDs :: UsageDetails -> UsageDetails -> UsageDetails thenUDs (MkUD {ud_binds = db1, ud_calls = calls1}) (MkUD {ud_binds = db2, ud_calls = calls2}) ===================================== compiler/GHC/Core/Predicate.hs ===================================== @@ -24,7 +24,7 @@ module GHC.Core.Predicate ( classMethodTy, classMethodInstTy, -- Implicit parameters - isIPLikePred, mentionsIP, isIPTyCon, isIPClass, + couldBeIPLike, mightMentionIP, isIPTyCon, isIPClass, isCallStackTy, isCallStackPred, isCallStackPredTy, isExceptionContextPred, isExceptionContextTy, isIPPred_maybe, @@ -127,7 +127,7 @@ isDictTy ty = isClassPred pred typeDeterminesValue :: Type -> Bool -- See Note [Type determines value] -typeDeterminesValue ty = isDictTy ty && not (isIPLikePred ty) +typeDeterminesValue ty = isDictTy ty && not (couldBeIPLike ty) getClassPredTys :: HasDebugCallStack => PredType -> (Class, [Type]) getClassPredTys ty = case getClassPredTys_maybe ty of @@ -424,44 +424,44 @@ isCallStackTy ty | otherwise = False --- --------------------- isIPLike and mentionsIP -------------------------- +-- --------------------- couldBeIPLike and mightMentionIP -------------------------- -- See Note [Local implicit parameters] -isIPLikePred :: Type -> Bool +couldBeIPLike :: Type -> Bool -- Is `pred`, or any of its superclasses, an implicit parameter? -- See Note [Local implicit parameters] -isIPLikePred pred = - mentions_ip_pred initIPRecTc (const True) (const True) pred - -mentionsIP :: (Type -> Bool) -- ^ predicate on the string - -> (Type -> Bool) -- ^ predicate on the type - -> Class - -> [Type] -> Bool --- ^ @'mentionsIP' str_cond ty_cond cls tys@ returns @True@ if: +couldBeIPLike pred + = might_mention_ip1 initIPRecTc (const True) (const True) pred + +mightMentionIP :: (Type -> Bool) -- ^ predicate on the string + -> (Type -> Bool) -- ^ predicate on the type + -> Class + -> [Type] -> Bool +-- ^ @'mightMentionIP' str_cond ty_cond cls tys@ returns @True@ if: -- -- - @cls tys@ is of the form @IP str ty@, where @str_cond str@ and @ty_cond ty@ -- are both @True@, -- - or any superclass of @cls tys@ has this property. -- -- See Note [Local implicit parameters] -mentionsIP = mentions_ip initIPRecTc +mightMentionIP = might_mention_ip initIPRecTc -mentions_ip :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Class -> [Type] -> Bool -mentions_ip rec_clss str_cond ty_cond cls tys +might_mention_ip :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Class -> [Type] -> Bool +might_mention_ip rec_clss str_cond ty_cond cls tys | Just (str_ty, ty) <- isIPPred_maybe cls tys = str_cond str_ty && ty_cond ty | otherwise - = or [ mentions_ip_pred rec_clss str_cond ty_cond (classMethodInstTy sc_sel_id tys) + = or [ might_mention_ip1 rec_clss str_cond ty_cond (classMethodInstTy sc_sel_id tys) | sc_sel_id <- classSCSelIds cls ] -mentions_ip_pred :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Type -> Bool -mentions_ip_pred rec_clss str_cond ty_cond ty +might_mention_ip1 :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Type -> Bool +might_mention_ip1 rec_clss str_cond ty_cond ty | Just (cls, tys) <- getClassPredTys_maybe ty , let tc = classTyCon cls , Just rec_clss' <- if isTupleTyCon tc then Just rec_clss else checkRecTc rec_clss tc - = mentions_ip rec_clss' str_cond ty_cond cls tys + = might_mention_ip rec_clss' str_cond ty_cond cls tys | otherwise = False -- Includes things like (D []) where D is -- a Constraint-ranged family; #7785 @@ -474,7 +474,7 @@ initIPRecTc = setRecTcMaxBound 1 initRecTc See also wrinkle (SIP1) in Note [Shadowing of implicit parameters] in GHC.Tc.Solver.Dict. -The function isIPLikePred tells if this predicate, or any of its +The function couldBeIPLike tells if this predicate, or any of its superclasses, is an implicit parameter. Why are implicit parameters special? Unlike normal classes, we can @@ -482,7 +482,7 @@ have local instances for implicit parameters, in the form of let ?x = True in ... So in various places we must be careful not to assume that any value of the right type will do; we must carefully look for the innermost binding. -So isIPLikePred checks whether this is an implicit parameter, or has +So couldBeIPLike checks whether this is an implicit parameter, or has a superclass that is an implicit parameter. Several wrinkles @@ -523,16 +523,16 @@ Small worries (Sept 20): think nothing does. * I'm a little concerned about type variables; such a variable might be instantiated to an implicit parameter. I don't think this - matters in the cases for which isIPLikePred is used, and it's pretty + matters in the cases for which couldBeIPLike is used, and it's pretty obscure anyway. * The superclass hunt stops when it encounters the same class again, but in principle we could have the same class, differently instantiated, and the second time it could have an implicit parameter I'm going to treat these as problems for another day. They are all exotic. -Note [Using typesAreApart when calling mentionsIP] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We call 'mentionsIP' in two situations: +Note [Using typesAreApart when calling mightMentionIP] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We call 'mightMentionIP' in two situations: (1) to check that a predicate does not contain any implicit parameters IP str ty, for a fixed literal str and any type ty, ===================================== compiler/GHC/Tc/Solver.hs ===================================== @@ -1902,7 +1902,7 @@ growThetaTyVars theta tcvs | otherwise = transCloVarSet mk_next seed_tcvs where seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips - (ips, non_ips) = partition isIPLikePred theta + (ips, non_ips) = partition couldBeIPLike theta -- See Note [Inheriting implicit parameters] mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones ===================================== compiler/GHC/Tc/Solver/Dict.hs ===================================== @@ -749,7 +749,7 @@ shortCutSolver dflags ev_w ev_i -- programs should typecheck regardless of whether we take this step or -- not. See Note [Shortcut solving] - , not (isIPLikePred (ctEvPred ev_w)) -- Not for implicit parameters (#18627) + , not (couldBeIPLike (ctEvPred ev_w)) -- Not for implicit parameters (#18627) , not (xopt LangExt.IncoherentInstances dflags) -- If IncoherentInstances is on then we cannot rely on coherence of proofs ===================================== compiler/GHC/Tc/Solver/InertSet.hs ===================================== @@ -2013,10 +2013,10 @@ solveOneFromTheOther ct_i ct_w is_wsc_orig_w = isWantedSuperclassOrigin orig_w different_level_strategy -- Both Given - | isIPLikePred pred = if lvl_w `strictlyDeeperThan` lvl_i then KeepWork else KeepInert - | otherwise = if lvl_w `strictlyDeeperThan` lvl_i then KeepInert else KeepWork + | couldBeIPLike pred = if lvl_w `strictlyDeeperThan` lvl_i then KeepWork else KeepInert + | otherwise = if lvl_w `strictlyDeeperThan` lvl_i then KeepInert else KeepWork -- See Note [Replacement vs keeping] part (1) - -- For the isIPLikePred case see Note [Shadowing of implicit parameters] + -- For the couldBeIPLike case see Note [Shadowing of implicit parameters] -- in GHC.Tc.Solver.Dict same_level_strategy -- Both Given ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -396,8 +396,8 @@ updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys }) -- an implicit parameter (?str :: ty) for the given 'str' and any type 'ty'? does_not_mention_ip_for :: Type -> DictCt -> Bool does_not_mention_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys }) - = not $ mentionsIP (not . typesAreApart str_ty) (const True) cls tys - -- See Note [Using typesAreApart when calling mentionsIP] + = not $ mightMentionIP (not . typesAreApart str_ty) (const True) cls tys + -- See Note [Using typesAreApart when calling mightMmentionIP] -- in GHC.Core.Predicate updInertIrreds :: IrredCt -> TcS () @@ -533,7 +533,7 @@ updSolvedDicts what dict_ct@(DictCt { di_cls = cls, di_tys = tys, di_ev = ev }) = do { is_callstack <- is_tyConTy isCallStackTy callStackTyConName ; is_exceptionCtx <- is_tyConTy isExceptionContextTy exceptionContextTyConName ; let contains_callstack_or_exceptionCtx = - mentionsIP + mightMentionIP (const True) -- NB: the name of the call-stack IP is irrelevant -- e.g (?foo :: CallStack) counts! @@ -551,9 +551,9 @@ updSolvedDicts what dict_ct@(DictCt { di_cls = cls, di_tys = tys, di_ev = ev }) -- Return a predicate that decides whether a type is CallStack -- or ExceptionContext, accounting for e.g. type family reduction, as - -- per Note [Using typesAreApart when calling mentionsIP]. + -- per Note [Using typesAreApart when calling mightMentionIP]. -- - -- See Note [Using isCallStackTy in mentionsIP]. + -- See Note [Using isCallStackTy in mightMentionIP]. is_tyConTy :: (Type -> Bool) -> Name -> TcS (Type -> Bool) is_tyConTy is_eq tc_name = do { (mb_tc, _) <- wrapTcS $ TcM.tryTc $ TcM.tcLookupTyCon tc_name @@ -581,14 +581,14 @@ in a different context! See also Note [Shadowing of implicit parameters], which deals with a similar problem with Given implicit parameter constraints. -Note [Using isCallStackTy in mentionsIP] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Using isCallStackTy in mightMentionIP] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ To implement Note [Don't add HasCallStack constraints to the solved set], we need to check whether a constraint contains a HasCallStack or HasExceptionContext constraint. We do this using the 'mentionsIP' function, but as per -Note [Using typesAreApart when calling mentionsIP] we don't want to simply do: +Note [Using typesAreApart when calling mightMentions] we don't want to simply do: - mentionsIP + mightMentionIP (const True) -- (ignore the implicit parameter string) (isCallStackTy <||> isExceptionContextTy) ===================================== compiler/GHC/Tc/Utils/TcType.hs ===================================== @@ -155,7 +155,7 @@ module GHC.Tc.Utils.TcType ( mkTyConTy, mkTyVarTy, mkTyVarTys, mkTyCoVarTy, mkTyCoVarTys, - isClassPred, isEqPred, isIPLikePred, isEqClassPred, + isClassPred, isEqPred, couldBeIPLike, isEqClassPred, isEqualityClass, mkClassPred, tcSplitQuantPredTy, tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy, isRuntimeRepVar, isFixedRuntimeRepKind, @@ -1819,7 +1819,7 @@ pickCapturedPreds pickCapturedPreds qtvs theta = filter captured theta where - captured pred = isIPLikePred pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs) + captured pred = couldBeIPLike pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs) -- Superclasses View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/483a939e118d1472ce32ac95b43e6d5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/483a939e118d1472ce32ac95b43e6d5… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Doc: add doc for JS interruptible calling convention (#24444)
by Marge Bot (＠marge-bot) 26 Apr '25

26 Apr '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: fe6ed8d9 by Sylvain Henry at 2025-04-24T18:04:12-04:00 Doc: add doc for JS interruptible calling convention (#24444) - - - - - 6111c5e4 by Ben Gamari at 2025-04-24T18:04:53-04:00 compiler: Ensure that Panic.Plain.assertPanic' provides callstack In 36cddd2ce1a3bc62ea8a1307d8bc6006d54109cf @alt-romes removed CallStack output from `GHC.Utils.Panic.Plain.assertPanic'`. While this output is redundant due to the exception backtrace proposal, we may be bootstrapping with a compiler which does not yet include this machinery. Reintroduce the output for now. Fixes #25898. - - - - - 217caad1 by Matthew Pickering at 2025-04-25T18:58:42+01:00 Implement Explicit Level Imports for Template Haskell This commit introduces the `ExplicitLevelImports` and `ImplicitStagePersistence` language extensions as proposed in GHC Proposal #682. Key Features ------------ - `ExplicitLevelImports` adds two new import modifiers - `splice` and `quote` - allowing precise control over the level at which imported identifiers are available - `ImplicitStagePersistence` (enabled by default) preserves existing path-based cross-stage persistence behavior - `NoImplicitStagePersistence` disables implicit cross-stage persistence, requiring explicit level imports Benefits -------- - Improved compilation performance by reducing unnecessary code generation - Enhanced IDE experience with faster feedback in `-fno-code` mode - Better dependency tracking by distinguishing compile-time and runtime dependencies - Foundation for future cross-compilation improvements This implementation enables the separation of modules needed at compile-time from those needed at runtime, allowing for more efficient compilation pipelines and clearer code organization in projects using Template Haskell. Implementation Notes -------------------- The level which a name is availble at is stored in the 'GRE', in the normal GlobalRdrEnv. The function `greLevels` returns the levels which a specific GRE is imported at. The level information for a 'Name' is computed by `getCurrentAndBindLevel`. The level validity is checked by `checkCrossLevelLifting`. Instances are checked by `checkWellLevelledDFun`, which computes the level an instance by calling `checkWellLevelledInstanceWhat`, which sees what is available at by looking at the module graph. Modifications to downsweep -------------------------- Code generation is now only enabled for modules which are needed at compile time. See the Note [-fno-code mode] for more information. Uniform error messages for level errors --------------------------------------- All error messages to do with levels are now reported uniformly using the `TcRnBadlyStaged` constructor. Error messages are uniformly reported in terms of levels. 0 - top-level 1 - quote level -1 - splice level The only level hard-coded into the compiler is the top-level in GHC.Types.ThLevelIndex.topLevelIndex. Uniformly refer to levels and stages ------------------------------------ There was much confusion about levels vs stages in the compiler. A level is a semantic concept, used by the typechecker to ensure a program can be evaluated in a well-staged manner. A stage is an operational construct, program evaluation proceeds in stages. Deprecate -Wbadly-staged-types ------------------------------ `-Wbadly-staged-types` is deprecated in favour of `-Wbadly-levelled-types`. Lift derivation changed ----------------------- Derived lift instances will now not generate code with expression quotations. Before: ``` data A = A Int deriving Lift => lift (A x) = [| A $(lift x) |] ``` After: ``` lift (A x) = conE 'A `appE` (lift x) ``` This is because if you attempt to derive `Lift` in a module where `NoImplicitStagePersistence` is enabled, you would get an infinite loop where a constructor was attempted to be persisted using the instance you are currently defining. GHC API Changes --------------- The ModuleGraph now contains additional information about the type of the edges (normal, quote or splice) between modules. This is abstracted using the `ModuleGraphEdge` data type. Fixes #25828 ------------------------- Metric Increase: MultiLayerModulesTH_Make ------------------------- - - - - - b39228a6 by Simon Peyton Jones at 2025-04-26T15:34:09-04:00 Get a decent MatchContext for pattern synonym bindings In particular when we have a pattern binding K p1 .. pn = rhs where K is a pattern synonym. (It might be nested.) This small MR fixes #25995. It's a tiny fix, to an error message, removing an always-dubious `unkSkol`. The bug report was in the context of horde-ad, a big program, and I didn't manage to make a small repro case quickly. I decided not to bother further. - - - - - 268 changed files: - compiler/GHC.hs - compiler/GHC/Data/Graph/Directed/Reachability.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/MakeFile.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Errors/Ppr.hs - compiler/GHC/Parser/Errors/Types.hs - compiler/GHC/Parser/Header.hs - compiler/GHC/Parser/Lexer.x - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/Deriv/Utils.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Plugin.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Types/TH.hs - compiler/GHC/Tc/Utils/Backpack.hs - compiler/GHC/Tc/Utils/Concrete.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Name/Reader.hs - + compiler/GHC/Types/ThLevelIndex.hs - compiler/GHC/Unit/Home/PackageTable.hs - compiler/GHC/Unit/Module/Deps.hs - compiler/GHC/Unit/Module/Graph.hs - compiler/GHC/Unit/Module/Imported.hs - compiler/GHC/Unit/Module/ModSummary.hs - + compiler/GHC/Unit/Module/Stage.hs - compiler/GHC/Unit/Types.hs - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Outputable.hs - compiler/GHC/Utils/Panic/Plain.hs - compiler/Language/Haskell/Syntax/ImpExp.hs - + compiler/Language/Haskell/Syntax/ImpExp/IsBoot.hs - compiler/ghc.cabal.in - docs/users_guide/exts/control.rst - docs/users_guide/exts/template_haskell.rst - docs/users_guide/javascript.rst - docs/users_guide/phases.rst - docs/users_guide/using-warnings.rst - ghc/GHCi/UI.hs - libraries/base/tests/IO/Makefile - libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs - testsuite/tests/ado/ado004.stderr - testsuite/tests/annotations/should_fail/annfail03.stderr - testsuite/tests/annotations/should_fail/annfail04.stderr - testsuite/tests/annotations/should_fail/annfail06.stderr - testsuite/tests/annotations/should_fail/annfail09.stderr - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/dependent/should_compile/T14729.stderr - testsuite/tests/dependent/should_compile/T15743.stderr - testsuite/tests/dependent/should_compile/T15743e.stderr - testsuite/tests/deriving/should_compile/T14682.stderr - testsuite/tests/determinism/determ021/determ021.stdout - + testsuite/tests/driver/T4437.stdout - testsuite/tests/driver/json2.stderr - testsuite/tests/gadt/T19847a.stderr - testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs - testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs - testsuite/tests/indexed-types/should_compile/T15711.stderr - testsuite/tests/indexed-types/should_compile/T15852.stderr - testsuite/tests/indexed-types/should_compile/T3017.stderr - testsuite/tests/interface-stability/template-haskell-exports.stdout - testsuite/tests/module/mod185.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T14189.stderr - testsuite/tests/partial-sigs/should_compile/ADT.stderr - testsuite/tests/partial-sigs/should_compile/AddAndOr1.stderr - testsuite/tests/partial-sigs/should_compile/AddAndOr2.stderr - testsuite/tests/partial-sigs/should_compile/AddAndOr3.stderr - testsuite/tests/partial-sigs/should_compile/AddAndOr4.stderr - testsuite/tests/partial-sigs/should_compile/AddAndOr5.stderr - testsuite/tests/partial-sigs/should_compile/AddAndOr6.stderr - testsuite/tests/partial-sigs/should_compile/BoolToBool.stderr - testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr - testsuite/tests/partial-sigs/should_compile/Defaulting1MROn.stderr - testsuite/tests/partial-sigs/should_compile/Defaulting2MROff.stderr - testsuite/tests/partial-sigs/should_compile/Defaulting2MROn.stderr - testsuite/tests/partial-sigs/should_compile/Either.stderr - testsuite/tests/partial-sigs/should_compile/EqualityConstraint.stderr - testsuite/tests/partial-sigs/should_compile/Every.stderr - testsuite/tests/partial-sigs/should_compile/EveryNamed.stderr - testsuite/tests/partial-sigs/should_compile/ExpressionSig.stderr - testsuite/tests/partial-sigs/should_compile/ExpressionSigNamed.stderr - testsuite/tests/partial-sigs/should_compile/ExtraConstraints1.stderr - testsuite/tests/partial-sigs/should_compile/ExtraConstraints2.stderr - testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr - testsuite/tests/partial-sigs/should_compile/ExtraNumAMROff.stderr - testsuite/tests/partial-sigs/should_compile/ExtraNumAMROn.stderr - testsuite/tests/partial-sigs/should_compile/Forall1.stderr - testsuite/tests/partial-sigs/should_compile/GenNamed.stderr - testsuite/tests/partial-sigs/should_compile/HigherRank1.stderr - testsuite/tests/partial-sigs/should_compile/HigherRank2.stderr - testsuite/tests/partial-sigs/should_compile/LocalDefinitionBug.stderr - testsuite/tests/partial-sigs/should_compile/Meltdown.stderr - testsuite/tests/partial-sigs/should_compile/MonoLocalBinds.stderr - testsuite/tests/partial-sigs/should_compile/NamedTyVar.stderr - testsuite/tests/partial-sigs/should_compile/NamedWildcardInDataFamilyInstanceLHS.stderr - testsuite/tests/partial-sigs/should_compile/NamedWildcardInTypeFamilyInstanceLHS.stderr - testsuite/tests/partial-sigs/should_compile/ParensAroundContext.stderr - testsuite/tests/partial-sigs/should_compile/PatBind.stderr - testsuite/tests/partial-sigs/should_compile/PatBind2.stderr - testsuite/tests/partial-sigs/should_compile/PatternSig.stderr - testsuite/tests/partial-sigs/should_compile/Recursive.stderr - testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcards.stderr - testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcardsGood.stderr - testsuite/tests/partial-sigs/should_compile/ShowNamed.stderr - testsuite/tests/partial-sigs/should_compile/SimpleGen.stderr - testsuite/tests/partial-sigs/should_compile/SkipMany.stderr - testsuite/tests/partial-sigs/should_compile/SomethingShowable.stderr - testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.stderr - testsuite/tests/partial-sigs/should_compile/Uncurry.stderr - testsuite/tests/partial-sigs/should_compile/UncurryNamed.stderr - testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr - testsuite/tests/polykinds/T15592.stderr - testsuite/tests/polykinds/T15592b.stderr - testsuite/tests/printer/T18052a.stderr - testsuite/tests/quasiquotation/qq001/qq001.stderr - testsuite/tests/quasiquotation/qq002/qq002.stderr - testsuite/tests/quasiquotation/qq003/qq003.stderr - testsuite/tests/quasiquotation/qq004/qq004.stderr - + testsuite/tests/quotes/T5721.stderr - testsuite/tests/roles/should_compile/Roles1.stderr - testsuite/tests/roles/should_compile/Roles14.stderr - testsuite/tests/roles/should_compile/Roles2.stderr - testsuite/tests/roles/should_compile/Roles3.stderr - testsuite/tests/roles/should_compile/Roles4.stderr - testsuite/tests/roles/should_compile/T8958.stderr - testsuite/tests/showIface/DocsInHiFile1.stdout - testsuite/tests/showIface/DocsInHiFileTH.stdout - testsuite/tests/showIface/HaddockIssue849.stdout - testsuite/tests/showIface/HaddockOpts.stdout - testsuite/tests/showIface/HaddockSpanIssueT24378.stdout - testsuite/tests/showIface/LanguageExts.stdout - testsuite/tests/showIface/MagicHashInHaddocks.stdout - testsuite/tests/showIface/NoExportList.stdout - testsuite/tests/showIface/PragmaDocs.stdout - testsuite/tests/showIface/ReExports.stdout - + testsuite/tests/splice-imports/ClassA.hs - + testsuite/tests/splice-imports/InstanceA.hs - + testsuite/tests/splice-imports/Makefile - + testsuite/tests/splice-imports/SI01.hs - + testsuite/tests/splice-imports/SI01A.hs - + testsuite/tests/splice-imports/SI02.hs - + testsuite/tests/splice-imports/SI03.hs - + testsuite/tests/splice-imports/SI03.stderr - + testsuite/tests/splice-imports/SI04.hs - + testsuite/tests/splice-imports/SI05.hs - + testsuite/tests/splice-imports/SI05.stderr - + testsuite/tests/splice-imports/SI05A.hs - + testsuite/tests/splice-imports/SI06.hs - + testsuite/tests/splice-imports/SI07.hs - + testsuite/tests/splice-imports/SI07.stderr - + testsuite/tests/splice-imports/SI07A.hs - + testsuite/tests/splice-imports/SI08.hs - + testsuite/tests/splice-imports/SI08.stderr - + testsuite/tests/splice-imports/SI08_oneshot.stderr - + testsuite/tests/splice-imports/SI09.hs - + testsuite/tests/splice-imports/SI10.hs - + testsuite/tests/splice-imports/SI13.hs - + testsuite/tests/splice-imports/SI14.hs - + testsuite/tests/splice-imports/SI14.stderr - + testsuite/tests/splice-imports/SI15.hs - + testsuite/tests/splice-imports/SI15.stderr - + testsuite/tests/splice-imports/SI16.hs - + testsuite/tests/splice-imports/SI16.stderr - + testsuite/tests/splice-imports/SI17.hs - + testsuite/tests/splice-imports/SI18.hs - + testsuite/tests/splice-imports/SI18.stderr - + testsuite/tests/splice-imports/SI19.hs - + testsuite/tests/splice-imports/SI19A.hs - + testsuite/tests/splice-imports/SI20.hs - + testsuite/tests/splice-imports/SI20.stderr - + testsuite/tests/splice-imports/SI21.hs - + testsuite/tests/splice-imports/SI21.stderr - + testsuite/tests/splice-imports/SI22.hs - + testsuite/tests/splice-imports/SI22.stderr - + testsuite/tests/splice-imports/SI23.hs - + testsuite/tests/splice-imports/SI23A.hs - + testsuite/tests/splice-imports/SI24.hs - + testsuite/tests/splice-imports/SI25.hs - + testsuite/tests/splice-imports/SI25.stderr - + testsuite/tests/splice-imports/SI25Helper.hs - + testsuite/tests/splice-imports/SI26.hs - + testsuite/tests/splice-imports/SI27.hs - + testsuite/tests/splice-imports/SI27.stderr - + testsuite/tests/splice-imports/SI28.hs - + testsuite/tests/splice-imports/SI28.stderr - + testsuite/tests/splice-imports/SI29.hs - + testsuite/tests/splice-imports/SI29.stderr - + testsuite/tests/splice-imports/SI30.script - + testsuite/tests/splice-imports/SI30.stdout - + testsuite/tests/splice-imports/SI31.script - + testsuite/tests/splice-imports/SI31.stderr - + testsuite/tests/splice-imports/SI32.script - + testsuite/tests/splice-imports/SI32.stdout - + testsuite/tests/splice-imports/SI33.script - + testsuite/tests/splice-imports/SI33.stdout - + testsuite/tests/splice-imports/SI34.hs - + testsuite/tests/splice-imports/SI34.stderr - + testsuite/tests/splice-imports/SI34M1.hs - + testsuite/tests/splice-imports/SI34M2.hs - + testsuite/tests/splice-imports/SI35.hs - + testsuite/tests/splice-imports/SI35A.hs - + testsuite/tests/splice-imports/SI36.hs - + testsuite/tests/splice-imports/SI36.stderr - + testsuite/tests/splice-imports/SI36_A.hs - + testsuite/tests/splice-imports/SI36_B1.hs - + testsuite/tests/splice-imports/SI36_B2.hs - + testsuite/tests/splice-imports/SI36_B3.hs - + testsuite/tests/splice-imports/SI36_C1.hs - + testsuite/tests/splice-imports/SI36_C2.hs - + testsuite/tests/splice-imports/SI36_C3.hs - + testsuite/tests/splice-imports/all.T - testsuite/tests/th/T16976z.stderr - testsuite/tests/th/T17820a.stderr - testsuite/tests/th/T17820b.stderr - testsuite/tests/th/T17820c.stderr - testsuite/tests/th/T17820d.stderr - testsuite/tests/th/T17820e.stderr - testsuite/tests/th/T21547.stderr - testsuite/tests/th/T23829_hasty.stderr - testsuite/tests/th/T23829_hasty_b.stderr - testsuite/tests/th/T23829_tardy.ghc.stderr - testsuite/tests/th/T5795.stderr - testsuite/tests/th/TH_Roles2.stderr - testsuite/tests/typecheck/should_compile/T12763.stderr - testsuite/tests/typecheck/should_compile/T18406b.stderr - testsuite/tests/typecheck/should_compile/T18529.stderr - testsuite/tests/typecheck/should_compile/T21023.stderr - utils/check-exact/ExactPrint.hs - utils/count-deps/Main.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/271d4baa2ae8320363dbe89264045c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/271d4baa2ae8320363dbe89264045c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T24603] aligned tests
by Serge S. Gulin (＠gulin.serge) 26 Apr '25

26 Apr '25

Serge S. Gulin pushed to branch wip/T24603 at Glasgow Haskell Compiler / GHC Commits: 42b7be07 by Serge S. Gulin at 2025-04-26T20:57:52+03:00 aligned tests - - - - - 2 changed files: - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs Changes: ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -10491,7 +10491,6 @@ module System.Posix.Internals where c_lseek :: GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.System.Posix.Types.COff -> GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO GHC.Internal.System.Posix.Types.COff c_mkfifo :: GHC.Internal.Foreign.C.String.Encoding.CString -> GHC.Internal.System.Posix.Types.CMode -> GHC.Internal.Types.IO GHC.Internal.Foreign.C.Types.CInt c_open :: CFilePath -> GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.System.Posix.Types.CMode -> GHC.Internal.Types.IO GHC.Internal.Foreign.C.Types.CInt - c_openat :: GHC.Internal.Foreign.C.Types.CInt -> CFilePath -> GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.System.Posix.Types.CMode -> GHC.Internal.Types.IO GHC.Internal.Foreign.C.Types.CInt c_pipe :: GHC.Internal.Ptr.Ptr GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO GHC.Internal.Foreign.C.Types.CInt c_read :: GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Ptr.Ptr GHC.Internal.Word.Word8 -> GHC.Internal.Foreign.C.Types.CSize -> GHC.Internal.Types.IO GHC.Internal.System.Posix.Types.CSsize c_s_isblk :: GHC.Internal.System.Posix.Types.CMode -> GHC.Internal.Foreign.C.Types.CInt ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -13536,6 +13536,7 @@ module System.Posix.Internals where c_lseek :: GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.System.Posix.Types.COff -> GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO GHC.Internal.System.Posix.Types.COff c_mkfifo :: GHC.Internal.Foreign.C.String.Encoding.CString -> GHC.Internal.System.Posix.Types.CMode -> GHC.Internal.Types.IO GHC.Internal.Foreign.C.Types.CInt c_open :: CFilePath -> GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.System.Posix.Types.CMode -> GHC.Internal.Types.IO GHC.Internal.Foreign.C.Types.CInt + c_openat :: GHC.Internal.Foreign.C.Types.CInt -> CFilePath -> GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.System.Posix.Types.CMode -> GHC.Internal.Types.IO GHC.Internal.Foreign.C.Types.CInt c_pipe :: GHC.Internal.Ptr.Ptr GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO GHC.Internal.Foreign.C.Types.CInt c_read :: GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Ptr.Ptr GHC.Internal.Word.Word8 -> GHC.Internal.Foreign.C.Types.CSize -> GHC.Internal.Types.IO GHC.Internal.System.Posix.Types.CSsize c_s_isblk :: GHC.Internal.System.Posix.Types.CMode -> GHC.Internal.Foreign.C.Types.CInt View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/42b7be07238a0d789f6d5405cac1dc4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/42b7be07238a0d789f6d5405cac1dc4… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T25944] CprAnal: Detect recursive newtypes (#25944)
by Sebastian Graf (＠sgraf812) 26 Apr '25

26 Apr '25

Sebastian Graf pushed to branch wip/T25944 at Glasgow Haskell Compiler / GHC Commits: 6425a1f0 by Sebastian Graf at 2025-04-26T14:35:17+02:00 CprAnal: Detect recursive newtypes (#25944) While `cprTransformDataConWork` handles recursive data con workers, it did not detect the case when a newtype is responsible for the recursion. This is now detected in the `Cast` case of `cprAnal`. The same reproducer made it clear that `isRecDataCon` lacked congruent handling for `AppTy` and `CastTy`, now fixed. Furthermore, the new repro case T25944 triggered this bug via an infinite loop in `cprFix`, caused by the infelicity in `isRecDataCon`. While it should be much less likely to trigger such an infinite loop now that `isRecDataCon` has been fixed, I made sure to abort the loop after 10 iterations and emitting a warning instead. Fixes #25944. - - - - - 5 changed files: - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - + testsuite/tests/cpranal/sigs/T25944.hs - + testsuite/tests/cpranal/sigs/T25944.stderr - testsuite/tests/cpranal/sigs/all.T Changes: ===================================== compiler/GHC/Core/Opt/CprAnal.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE MultiWayIf #-} -- | Constructed Product Result analysis. Identifies functions that surely -- return heap-allocated records on every code path, so that we can eliminate @@ -22,12 +23,15 @@ import GHC.Types.Demand import GHC.Types.Cpr import GHC.Types.Unique.MemoFun +import GHC.Core import GHC.Core.FamInstEnv import GHC.Core.DataCon import GHC.Core.Type import GHC.Core.Utils -import GHC.Core +import GHC.Core.Coercion +import GHC.Core.Reduction import GHC.Core.Seq +import GHC.Core.TyCon import GHC.Core.Opt.WorkWrap.Utils import GHC.Data.Graph.UnVar -- for UnVarSet @@ -216,9 +220,13 @@ cprAnal' _ (Type ty) = (topCprType, Type ty) -- Doesn't happen, in fact cprAnal' _ (Coercion co) = (topCprType, Coercion co) cprAnal' env (Cast e co) - = (cpr_ty, Cast e' co) + = (cpr_ty', Cast e' co) where (cpr_ty, e') = cprAnal env e + cpr_ty' + | cpr_ty == topCprType = topCprType -- cheap case first + | isRecNewTyConApp env (coercionRKind co) = topCprType -- See Note [CPR for recursive data constructors] + | otherwise = cpr_ty cprAnal' env (Tick t e) = (cpr_ty, Tick t e') @@ -391,6 +399,18 @@ cprTransformDataConWork env con args mAX_CPR_SIZE :: Arity mAX_CPR_SIZE = 10 +isRecNewTyConApp :: AnalEnv -> Type -> Bool +isRecNewTyConApp env ty + --- | pprTrace "isRecNewTyConApp" (ppr ty) False = undefined + | Just (tc, tc_args) <- splitTyConApp_maybe ty = + if | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe (ae_fam_envs env) tc tc_args + -> isRecNewTyConApp env rhs + | Just dc <- newTyConDataCon_maybe tc + -> ae_rec_dc env dc == DefinitelyRecursive + | otherwise + -> False + | otherwise = False + -- -- * Bindings -- @@ -414,12 +434,18 @@ cprFix orig_env orig_pairs | otherwise = orig_pairs init_env = extendSigEnvFromIds orig_env (map fst init_pairs) + -- If fixed-point iteration does not yield a result we use this instead + -- See Note [Safe abortion in the fixed-point iteration] + abort :: (AnalEnv, [(Id,CoreExpr)]) + abort = step (nonVirgin orig_env) [(setIdCprSig id topCprSig, rhs) | (id, rhs) <- orig_pairs ] + -- The fixed-point varies the idCprSig field of the binders and and their -- entries in the AnalEnv, and terminates if that annotation does not change -- any more. loop :: Int -> AnalEnv -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)]) loop n env pairs | found_fixpoint = (reset_env', pairs') + | n == 10 = pprTraceUserWarning (text "cprFix aborts. This is not terrible, but worth reporting a GHC issue." <+> ppr (map fst pairs)) $ abort | otherwise = loop (n+1) env' pairs' where -- In all but the first iteration, delete the virgin flag @@ -519,8 +545,9 @@ cprAnalBind env id rhs -- possibly trim thunk CPR info rhs_ty' -- See Note [CPR for thunks] - | stays_thunk = trimCprTy rhs_ty - | otherwise = rhs_ty + | rhs_ty == topCprType = topCprType -- cheap case first + | stays_thunk = trimCprTy rhs_ty + | otherwise = rhs_ty -- See Note [Arity trimming for CPR signatures] sig = mkCprSigForArity (idArity id) rhs_ty' -- See Note [OPAQUE pragma] @@ -639,7 +666,7 @@ data AnalEnv , ae_fam_envs :: FamInstEnvs -- ^ Needed when expanding type families and synonyms of product types. , ae_rec_dc :: DataCon -> IsRecDataConResult - -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataCon' + -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataType } instance Outputable AnalEnv where @@ -1042,10 +1069,11 @@ Eliminating the shared 'c' binding in the process. And then What can we do about it? - A. Don't CPR functions that return a *recursive data type* (the list in this - case). This is the solution we adopt. Rationale: the benefit of CPR on - recursive data structures is slight, because it only affects the outer layer - of a potentially massive data structure. + A. Don't give recursive data constructors or casts representing recursive newtype constructors + the CPR property (the list in this case). This is the solution we adopt. + Rationale: the benefit of CPR on recursive data structures is slight, + because it only affects the outer layer of a potentially massive data + structure. B. Don't CPR any *recursive function*. That would be quite conservative, as it would also affect e.g. the factorial function. C. Flat CPR only for recursive functions. This prevents the asymptotic @@ -1055,11 +1083,14 @@ What can we do about it? `c` in the second eqn of `replicateC`). But we'd need to know which paths were hot. We want such static branch frequency estimates in #20378. -We adopt solution (A) It is ad-hoc, but appears to work reasonably well. +We adopt solution (A). It is ad-hoc, but appears to work reasonably well. Deciding what a "recursive data constructor" is is quite tricky and ad-hoc, too: See Note [Detecting recursive data constructors]. We don't have to be perfect and can simply keep on unboxing if unsure. +(A) is implemented in `cprTransformDataConWork` for data types and in the +`Cast` case of `cprAnal` for newtypes. + Note [Detecting recursive data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ What qualifies as a "recursive data constructor" as per @@ -1075,12 +1106,15 @@ looks inside the following class of types, represented by `ty` (and responds types of its data constructors and check `tc_args` for recursion. C. If `ty = F tc_args`, `F` is a `FamTyCon` and we can reduce `F tc_args` to `rhs`, look into the `rhs` type. + D. If `ty = f a`, then look into `f` and `a` + E. If `ty = ty' |> co`, then look into `ty'` A few perhaps surprising points: 1. It deems any function type as non-recursive, because it's unlikely that a recursion through a function type builds up a recursive data structure. - 2. It doesn't look into kinds or coercion types because there's nothing to unbox. + 2. It doesn't look into kinds, literals or coercion types because we are + ultimately looking for value-level recursion. Same for promoted data constructors. 3. We don't care whether an AlgTyCon app `T tc_args` is fully saturated or not; we simply look at its definition/DataCons and its field tys and look for ===================================== compiler/GHC/Core/Opt/WorkWrap/Utils.hs ===================================== @@ -63,6 +63,7 @@ import Data.List ( unzip4 ) import GHC.Types.RepType import GHC.Unit.Types +import GHC.Core.TyCo.Rep {- ************************************************************************ @@ -1426,23 +1427,29 @@ isRecDataCon fam_envs fuel orig_dc | arg_ty <- map scaledThing (dataConRepArgTys dc) ] go_arg_ty :: IntWithInf -> TyConSet -> Type -> IsRecDataConResult - go_arg_ty fuel visited_tcs ty - --- | pprTrace "arg_ty" (ppr ty) False = undefined + go_arg_ty fuel visited_tcs ty = -- pprTrace "arg_ty" (ppr ty) $ + case coreFullView ty of + TyConApp tc tc_args -> go_tc_app fuel visited_tcs tc tc_args + -- See Note [Detecting recursive data constructors], points (B) and (C) - | Just (_tcv, ty') <- splitForAllTyCoVar_maybe ty - = go_arg_ty fuel visited_tcs ty' + ForAllTy _ ty' -> go_arg_ty fuel visited_tcs ty' -- See Note [Detecting recursive data constructors], point (A) - | Just (tc, tc_args) <- splitTyConApp_maybe ty - = go_tc_app fuel visited_tcs tc tc_args + CastTy ty' _ -> go_arg_ty fuel visited_tcs ty' - | otherwise - = NonRecursiveOrUnsure + AppTy f a -> go_arg_ty fuel visited_tcs f `combineIRDCR` go_arg_ty fuel visited_tcs a + -- See Note [Detecting recursive data constructors], point (D) + + FunTy{} -> NonRecursiveOrUnsure + -- See Note [Detecting recursive data constructors], point (1) + + -- (TyVarTy{} | LitTy{} | CastTy{}) + _ -> NonRecursiveOrUnsure go_tc_app :: IntWithInf -> TyConSet -> TyCon -> [Type] -> IsRecDataConResult go_tc_app fuel visited_tcs tc tc_args = case tyConDataCons_maybe tc of - --- | pprTrace "tc_app" (vcat [ppr tc, ppr tc_args]) False = undefined + ---_ | pprTrace "tc_app" (vcat [ppr tc, ppr tc_args]) False -> undefined _ | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe fam_envs tc tc_args -- This is the only place where we look at tc_args, which might have -- See Note [Detecting recursive data constructors], point (C) and (5) ===================================== testsuite/tests/cpranal/sigs/T25944.hs ===================================== @@ -0,0 +1,114 @@ +{-# LANGUAGE UndecidableInstances, LambdaCase #-} + +-- | This file starts with a small reproducer for #25944 that is easy to debug +-- and then continues with a much larger MWE that is faithful to the original +-- issue. +module T25944 (foo, bar, popMinOneT, popMinOne) where + +import Data.Functor.Identity ( Identity(..) ) +import Data.Coerce + +data ListCons a b = Nil | a :- !b +newtype Fix f = Fix (f (Fix f)) -- Rec + +foo :: Fix (ListCons a) -> Fix (ListCons a) -> Fix (ListCons a) +foo a b = go a + where + -- The outer loop arranges it so that the base case `go as` of `go2` is + -- bottom on the first iteration of the loop. + go (Fix Nil) = Fix Nil + go (Fix (a :- as)) = Fix (a :- go2 b) + where + go2 (Fix Nil) = go as + go2 (Fix (b :- bs)) = Fix (b :- go2 bs) + +bar :: Int -> (Fix (ListCons Int), Int) +bar n = (foo (Fix Nil) (Fix Nil), n) -- should still have CPR property + +-- Now the actual reproducer from #25944: + +newtype ListT m a = ListT { runListT :: m (ListCons a (ListT m a)) } + +cons :: Applicative m => a -> ListT m a -> ListT m a +cons x xs = ListT (pure (x :- xs)) + +nil :: Applicative m => ListT m a +nil = ListT (pure Nil) + +instance Functor m => Functor (ListT m) where + fmap f (ListT m) = ListT (go <$> m) + where + go Nil = Nil + go (a :- m) = f a :- (f <$> m) + +foldListT :: ((ListCons a (ListT m a) -> c) -> m (ListCons a (ListT m a)) -> b) + -> (a -> b -> c) + -> c + -> ListT m a -> b +foldListT r c n = r h . runListT + where + h Nil = n + h (x :- ListT xs) = c x (r h xs) +{-# INLINE foldListT #-} + +mapListT :: forall a m b. Monad m => (a -> ListT m b -> ListT m b) -> ListT m b -> ListT m a -> ListT m b +mapListT = + foldListT + ((coerce :: + ((ListCons a (ListT m a) -> m (ListCons b (ListT m b))) -> m (ListCons a (ListT m a)) -> m (ListCons b (ListT m b))) -> + ((ListCons a (ListT m a) -> ListT m b) -> m (ListCons a (ListT m a)) -> ListT m b)) + (=<<)) +{-# INLINE mapListT #-} + +instance Monad m => Applicative (ListT m) where + pure x = cons x nil + {-# INLINE pure #-} + liftA2 f xs ys = mapListT (\x zs -> mapListT (cons . f x) zs ys) nil xs + {-# INLINE liftA2 #-} + +instance Monad m => Monad (ListT m) where + xs >>= f = mapListT (flip (mapListT cons) . f) nil xs + {-# INLINE (>>=) #-} + +infixr 5 :< +data Node w a b = Leaf a | !w :< b + deriving (Functor) + +bimapNode f g (Leaf x) = Leaf (f x) +bimapNode f g (x :< xs) = x :< g xs + +newtype HeapT w m a = HeapT { runHeapT :: ListT m (Node w a (HeapT w m a)) } + +-- | The 'Heap' type, specialised to the 'Identity' monad. +type Heap w = HeapT w Identity + +instance Functor m => Functor (HeapT w m) where + fmap f = HeapT . fmap (bimapNode f (fmap f)) . runHeapT + +instance Monad m => Applicative (HeapT w m) where + pure = HeapT . pure . Leaf + (<*>) = liftA2 id + +instance Monad m => Monad (HeapT w m) where + HeapT m >>= f = HeapT (m >>= g) + where + g (Leaf x) = runHeapT (f x) + g (w :< xs) = pure (w :< (xs >>= f)) + +popMinOneT :: forall w m a. (Monoid w, Monad m) => HeapT w m a -> m (Maybe ((a, w), HeapT w m a)) +popMinOneT = go mempty [] . runHeapT + where + go' :: w -> Maybe (w, HeapT w m a) -> m (Maybe ((a, w), HeapT w m a)) + go' a Nothing = pure Nothing + go' a (Just (w, HeapT xs)) = go (a <> w) [] xs + + go :: w -> [(w, HeapT w m a)] -> ListT m (Node w a (HeapT w m a)) -> m (Maybe ((a, w), HeapT w m a)) + go w a (ListT xs) = xs >>= \case + Nil -> go' w (undefined) + Leaf x :- xs -> pure (Just ((x, w), undefined >> HeapT (foldl (\ys (yw,y) -> ListT (pure ((yw :< y) :- ys))) xs a))) + (u :< x) :- xs -> go w ((u,x) : a) xs +{-# INLINE popMinOneT #-} + +popMinOne :: Monoid w => Heap w a -> Maybe ((a, w), Heap w a) +popMinOne = runIdentity . popMinOneT +{-# INLINE popMinOne #-} ===================================== testsuite/tests/cpranal/sigs/T25944.stderr ===================================== @@ -0,0 +1,17 @@ + +==================== Cpr signatures ==================== +T25944.$fApplicativeHeapT: +T25944.$fApplicativeListT: +T25944.$fFunctorHeapT: +T25944.$fFunctorListT: +T25944.$fFunctorNode: +T25944.$fMonadHeapT: +T25944.$fMonadListT: +T25944.bar: 1 +T25944.foo: +T25944.popMinOne: 2(1(1,)) +T25944.popMinOneT: +T25944.runHeapT: +T25944.runListT: + + ===================================== testsuite/tests/cpranal/sigs/all.T ===================================== @@ -12,3 +12,4 @@ test('T16040', normal, compile, ['']) test('T19232', normal, compile, ['']) test('T19398', normal, compile, ['']) test('T19822', normal, compile, ['']) +test('T25944', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6425a1f063df92bc9a50870bb7e377a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6425a1f063df92bc9a50870bb7e377a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/spec_tyfams] Add test cases
by Andreas Klebinger (＠AndreasK) 26 Apr '25

26 Apr '25

Andreas Klebinger pushed to branch wip/andreask/spec_tyfams at Glasgow Haskell Compiler / GHC Commits: d4765de4 by Andreas Klebinger at 2025-04-26T14:08:14+02:00 Add test cases - - - - - 8 changed files: - + testsuite/tests/perf/should_run/SpecTyFamRun.hs - + testsuite/tests/perf/should_run/SpecTyFamRun.stdout - + testsuite/tests/perf/should_run/SpecTyFam_Import.hs - testsuite/tests/perf/should_run/all.T - + testsuite/tests/simplCore/should_compile/SpecTyFam.hs - + testsuite/tests/simplCore/should_compile/SpecTyFam.stderr - + testsuite/tests/simplCore/should_compile/SpecTyFam_Import.hs - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== testsuite/tests/perf/should_run/SpecTyFamRun.hs ===================================== @@ -0,0 +1,15 @@ +{-# OPTIONS_GHC -fspecialise-aggressively #-} +{-# OPTIONS_GHC -fno-spec-constr #-} +module Main(main) where + +import SpecTyFam_Import (specMe, MaybeShowNum) +import GHC.Exts + +-- We want to see a specialization of `specMe` which doesn't take a dictionary at runtime. + +{-# NOINLINE foo #-} +foo :: Int -> (String,Int) +-- We want specMe to be specialized, but not inlined +foo x = specMe True x + +main = print $ sum $ map (snd . foo) [1..1000 :: Int] ===================================== testsuite/tests/perf/should_run/SpecTyFamRun.stdout ===================================== @@ -0,0 +1 @@ +500500 ===================================== testsuite/tests/perf/should_run/SpecTyFam_Import.hs ===================================== @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} + +module SpecTyFam_Import (specMe, MaybeShowNum) where + +import Data.Kind + +type family MaybeShowNum a n :: Constraint where + MaybeShowNum a n = (Show a, Num n) + +{-# INLINABLE specMe #-} +specMe :: (Integral n, MaybeShowNum a n) => a -> n -> (String,n) +specMe s !n = (show s, n+1 `div` 2) ===================================== testsuite/tests/perf/should_run/all.T ===================================== @@ -423,3 +423,12 @@ test('ByteCodeAsm', ], compile_and_run, ['-package ghc']) + +# Check that $s$wspecMe doesn't have any dictionary args after specialization in addition to perf stats +# See also #19747 +test('SpecTyFamRun', [ grep_errmsg(r'foo') + , extra_files(['SpecTyFam_Import.hs']) + , only_ways(['optasm']) + , collect_stats('bytes allocated', 5)], + multimod_compile_and_run, + ['SpecTyFamRun', '-O2']) ===================================== testsuite/tests/simplCore/should_compile/SpecTyFam.hs ===================================== @@ -0,0 +1,15 @@ +{-# OPTIONS_GHC -fspecialise-aggressively #-} +{-# OPTIONS_GHC -fno-spec-constr #-} + +module SpecTyFam(main, foo) where + +import SpecTyFam_Import (specMe, MaybeShowNum) +import GHC.Exts + +-- We want to see a specialization of `specMe` which doesn't take a dictionary at runtime. + +{-# OPAQUE foo #-} +foo :: Int -> (String,Int) +foo x = specMe True x + +main = print $ sum $ map (snd . foo) [1..1000 :: Int] ===================================== testsuite/tests/simplCore/should_compile/SpecTyFam.stderr ===================================== @@ -0,0 +1,78 @@ +[1 of 2] Compiling SpecTyFam_Import ( SpecTyFam_Import.hs, SpecTyFam_Import.o ) + +==================== Specialise ==================== +Result size of Specialise = {terms: 31, types: 39, coercions: 8, joins: 0/1} + +-- RHS size: {terms: 30, types: 27, coercions: 8, joins: 0/1} +specMe [InlPrag=INLINABLE] :: forall n a. (Integral n, MaybeShowNum a n) => a -> n -> (String, n) +[LclIdX, + Arity=4, + Unf=Unf{Src=StableUser, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [30 0 0 20] 260 10 + Tmpl= \ (@n) (@a) ($dIntegral [Occ=Once1] :: Integral n) (irred :: MaybeShowNum a n) (eta [Occ=Once1] :: a) (eta [Occ=Once1] :: n) -> + let { + $dNum :: Num n + [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False, WorkFree=False, Expandable=True, Guidance=IF_ARGS [] 20 0}] + $dNum = GHC.Internal.Classes.$p1CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (SpecTyFam_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n))) } in + case eta of n [Occ=Once1] { __DEFAULT -> (show @a (GHC.Internal.Classes.$p0CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (SpecTyFam_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n)))) eta, + @n $dNum n (div @n $dIntegral (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 1#)) (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 2#)))) }}] +specMe + = \ (@n) (@a) ($dIntegral :: Integral n) (irred :: MaybeShowNum a n) (eta :: a) (eta :: n) -> + let { + $dNum :: Num n + [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False, WorkFree=False, Expandable=True, Guidance=IF_ARGS [] 20 0}] + $dNum = GHC.Internal.Classes.$p1CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (SpecTyFam_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n))) } in + case eta of n { __DEFAULT -> (show @a (GHC.Internal.Classes.$p0CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (SpecTyFam_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n)))) eta, + @n $dNum n (div @n $dIntegral (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 1#)) (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 2#)))) } + + + +[2 of 2] Compiling SpecTyFam ( SpecTyFam.hs, SpecTyFam.o ) + +==================== Specialise ==================== +Result size of Specialise = {terms: 84, types: 86, coercions: 13, joins: 0/1} + +Rec { +-- RHS size: {terms: 3, types: 4, coercions: 0, joins: 0/0} +$dCTuple2 :: (Show Bool, Num Int) +[LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +$dCTuple2 = (GHC.Internal.Show.$fShowBool, GHC.Internal.Num.$fNumInt) + +-- RHS size: {terms: 19, types: 9, coercions: 0, joins: 0/1} +$s$wspecMe [InlPrag=INLINABLE[2]] :: Bool -> Int -> (# String, Int #) +[LclId, Arity=2] +$s$wspecMe + = \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) -> + let { + $dNum :: Num Int + [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}] + $dNum = GHC.Internal.Num.$fNumInt } in + case eta1 of n1 [Occ=Once1] { __DEFAULT -> (# GHC.Internal.Show.$fShowBool_$cshow eta, GHC.Internal.Num.$fNumInt_$c+ n1 (GHC.Internal.Real.$fIntegralInt_$cdiv (GHC.Internal.Num.$fNumInt_$cfromInteger (GHC.Internal.Bignum.Integer.IS 1#)) (GHC.Internal.Num.$fNumInt_$cfromInteger (GHC.Internal.Bignum.Integer.IS 2#))) #) } + +-- RHS size: {terms: 12, types: 13, coercions: 5, joins: 0/0} +$sspecMe [InlPrag=INLINABLE[2]] :: Bool -> Int -> (String, Int) +[LclId, + Arity=2, + Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) + Tmpl= \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) -> case SpecTyFam_Import.$wspecMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (SpecTyFam_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) eta eta1 of { (# ww [Occ=Once1], ww1 [Occ=Once1] #) -> (ww, ww1) }}] +$sspecMe = \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) -> case SpecTyFam_Import.$wspecMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (SpecTyFam_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) eta eta1 of { (# ww [Occ=Once1], ww1 [Occ=Once1] #) -> (ww, ww1) } +end Rec } + +-- RHS size: {terms: 6, types: 3, coercions: 5, joins: 0/0} +foo [InlPrag=OPAQUE] :: Int -> (String, Int) +[LclIdX, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 50 0}] +foo = \ (x :: Int) -> specMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (SpecTyFam_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) GHC.Internal.Types.True x + +-- RHS size: {terms: 37, types: 26, coercions: 0, joins: 0/0} +main :: State# RealWorld -> (# State# RealWorld, () #) +[LclId, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 301 0}] +main = \ (eta [OS=OneShot] :: State# RealWorld) -> GHC.Internal.IO.Handle.Text.hPutStr2 GHC.Internal.IO.Handle.FD.stdout (case GHC.Internal.Enum.eftIntFB @(Int -> Int) (GHC.Internal.Base.mapFB @Int @(Int -> Int) @Int (\ (ds :: Int) (ds1 [OS=OneShot] :: Int -> Int) (v [OS=OneShot] :: Int) -> case v of { I# ipv -> ds1 (case ds of { I# y -> GHC.Internal.Types.I# (+# ipv y) }) }) (\ (x :: Int) -> case foo x of { (_ [Occ=Dead], y) -> y })) (breakpoint @Int) 1# 1000# (GHC.Internal.Types.I# 0#) of { I# n -> GHC.Internal.Show.itos n (GHC.Internal.Types.[] @Char) }) GHC.Internal.Types.True eta + +-- RHS size: {terms: 1, types: 0, coercions: 3, joins: 0/0} +main :: IO () +[LclIdX, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}] +main = main `cast` (Sym (GHC.Internal.Types.N:IO <()>_R) :: (State# RealWorld -> (# State# RealWorld, () #)) ~R# IO ()) + + +------ Local rules for imported ids -------- +"SPEC/SpecTyFam $wspecMe @Int @Bool" [2] forall ($dIntegral :: Integral Int) (irred :: MaybeShowNum Bool Int). SpecTyFam_Import.$wspecMe @Int @Bool $dIntegral irred = $s$wspecMe +"SPEC/SpecTyFam specMe @Int @Bool" [2] forall ($dIntegral :: Integral Int) (irred :: MaybeShowNum Bool Int). specMe @Int @Bool $dIntegral irred = $sspecMe + + ===================================== testsuite/tests/simplCore/should_compile/SpecTyFam_Import.hs ===================================== @@ -0,0 +1,14 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ImplicitParams #-} + +module SpecTyFam_Import (specMe, MaybeShowNum) where + +import Data.Kind + +type family MaybeShowNum a n :: Constraint where + MaybeShowNum a n = (Show a, Num n) + +{-# INLINABLE specMe #-} +specMe :: (Integral n, MaybeShowNum a n) => a -> n -> (String,n) +specMe s !n = (show s, n+1 `div` 2) ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -543,3 +543,10 @@ test('T25883c', normal, compile_grep_core, ['']) test('T25883d', [extra_files(['T25883d_import.hs'])], multimod_compile_filter, ['T25883d', '-O -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques', r'grep -e "y ="']) test('T25976', [grep_errmsg('Dead Code')], compile, ['-O -ddump-simpl -dsuppress-uniques -dno-typeable-binds']) + +# Check that $s$wspecMe doesn't have any dictionary args after specialization in addition to perf stats +test('SpecTyFam', [ grep_errmsg(r'\$wspecMe') + , extra_files(['SpecTyFam_Import.hs']) + , only_ways(['optasm'])], + multimod_compile, + ['SpecTyFam', '-O2 -ddump-spec -dsuppress-uniques -dno-typeable-binds -dppr-cols=1000']) \ No newline at end of file View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d4765de4afa1594688da2cb222a0c8d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d4765de4afa1594688da2cb222a0c8d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/spec_tyfams] use inscope set
by Andreas Klebinger (＠AndreasK) 26 Apr '25

26 Apr '25

Andreas Klebinger pushed to branch wip/andreask/spec_tyfams at Glasgow Haskell Compiler / GHC Commits: 6e9567ff by Andreas Klebinger at 2025-04-26T13:56:37+02:00 use inscope set - - - - - 1 changed file: - compiler/GHC/Core/Opt/Specialise.hs Changes: ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -1282,7 +1282,7 @@ specCase :: SpecEnv specCase env scrut' case_bndr [Alt con args rhs] | -- See Note [Floating dictionaries out of cases] -- interestingDict scrut' (idType case_bndr) - interestingDict (ISE emptyInScopeSet realIdUnfolding) scrut' + interestingDict (ISE (substInScopeSet $ se_subst env) realIdUnfolding) scrut' , not (isDeadBinder case_bndr && null sc_args') = do { case_bndr_flt :| sc_args_flt <- mapM clone_me (case_bndr' :| sc_args') @@ -3067,7 +3067,7 @@ mkCallUDs' env f args -- on this argument; if so, SpecDict, if not UnspecArg mk_spec_arg arg (Anon _pred af) | isInvisibleFunArg af - , interestingDict (ISE emptyInScopeSet realIdUnfolding) arg + , interestingDict (ISE (substInScopeSet $ se_subst env) realIdUnfolding) arg -- , interestingDict arg (scaledThing pred) -- See Note [Interesting dictionary arguments] = SpecDict arg View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6e9567ffa7a2a32ee68ce8a50e69866… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6e9567ffa7a2a32ee68ce8a50e69866… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T24603] aligned tests
by Serge S. Gulin (＠gulin.serge) 26 Apr '25

26 Apr '25

Serge S. Gulin pushed to branch wip/T24603 at Glasgow Haskell Compiler / GHC Commits: a73fdf14 by Serge S. Gulin at 2025-04-26T15:03:39+03:00 aligned tests - - - - - 1 changed file: - testsuite/tests/interface-stability/base-exports.stdout Changes: ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -10491,6 +10491,7 @@ module System.Posix.Internals where c_lseek :: GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.System.Posix.Types.COff -> GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO GHC.Internal.System.Posix.Types.COff c_mkfifo :: GHC.Internal.Foreign.C.String.Encoding.CString -> GHC.Internal.System.Posix.Types.CMode -> GHC.Internal.Types.IO GHC.Internal.Foreign.C.Types.CInt c_open :: CFilePath -> GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.System.Posix.Types.CMode -> GHC.Internal.Types.IO GHC.Internal.Foreign.C.Types.CInt + c_openat :: GHC.Internal.Foreign.C.Types.CInt -> CFilePath -> GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.System.Posix.Types.CMode -> GHC.Internal.Types.IO GHC.Internal.Foreign.C.Types.CInt c_pipe :: GHC.Internal.Ptr.Ptr GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Types.IO GHC.Internal.Foreign.C.Types.CInt c_read :: GHC.Internal.Foreign.C.Types.CInt -> GHC.Internal.Ptr.Ptr GHC.Internal.Word.Word8 -> GHC.Internal.Foreign.C.Types.CSize -> GHC.Internal.Types.IO GHC.Internal.System.Posix.Types.CSsize c_s_isblk :: GHC.Internal.System.Posix.Types.CMode -> GHC.Internal.Foreign.C.Types.CInt View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a73fdf14f61ccac46b07a457ec263c1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a73fdf14f61ccac46b07a457ec263c1… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/spec_tyfams] Disable trace for ci checks
by Andreas Klebinger (＠AndreasK) 26 Apr '25

26 Apr '25

Andreas Klebinger pushed to branch wip/andreask/spec_tyfams at Glasgow Haskell Compiler / GHC Commits: 701de524 by Andreas Klebinger at 2025-04-26T12:47:50+02:00 Disable trace for ci checks - - - - - 1 changed file: - compiler/GHC/Core/Opt/Specialise.hs Changes: ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -68,6 +68,7 @@ import Data.List.NonEmpty ( NonEmpty (..) ) import GHC.Core.Subst (substTickish) import GHC.Core.TyCon (tyConClass_maybe) import GHC.Core.DataCon (dataConTyCon) +import Control.Monad {- ************************************************************************ @@ -1704,7 +1705,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs , rule_bndrs, rule_lhs_args , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args - ; pprTrace "spec_call" (vcat + ; when False $ pprTrace "spec_call" (vcat [ text "fun: " <+> ppr fn , text "call info: " <+> ppr _ci , text "useful: " <+> ppr useful View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/701de52480878d9ceaeb4ee8a692b50… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/701de52480878d9ceaeb4ee8a692b50… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/spec_tyfams] Try simons version of isInterestingDict
by Andreas Klebinger (＠AndreasK) 26 Apr '25

26 Apr '25

Andreas Klebinger pushed to branch wip/andreask/spec_tyfams at Glasgow Haskell Compiler / GHC Commits: 9ec6b757 by Andreas Klebinger at 2025-04-26T12:37:22+02:00 Try simons version of isInterestingDict - - - - - 1 changed file: - compiler/GHC/Core/Opt/Specialise.hs Changes: ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -14,8 +14,8 @@ import GHC.Driver.Config.Diagnostic import GHC.Driver.Config.Core.Rules ( initRuleOpts ) import GHC.Core.Type hiding( substTy, substCo, extendTvSubst, zapSubst ) -import GHC.Core.Multiplicity -import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith ) +-- import GHC.Core.Multiplicity +import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith, exprIsConApp_maybe ) import GHC.Core.Predicate import GHC.Core.Coercion( Coercion ) import GHC.Core.Opt.Monad @@ -66,6 +66,8 @@ import GHC.Core.Unfold import Data.List( partition ) import Data.List.NonEmpty ( NonEmpty (..) ) import GHC.Core.Subst (substTickish) +import GHC.Core.TyCon (tyConClass_maybe) +import GHC.Core.DataCon (dataConTyCon) {- ************************************************************************ @@ -1278,7 +1280,8 @@ specCase :: SpecEnv , UsageDetails) specCase env scrut' case_bndr [Alt con args rhs] | -- See Note [Floating dictionaries out of cases] - interestingDict scrut' (idType case_bndr) + -- interestingDict scrut' (idType case_bndr) + interestingDict (ISE emptyInScopeSet realIdUnfolding) scrut' , not (isDeadBinder case_bndr && null sc_args') = do { case_bndr_flt :| sc_args_flt <- mapM clone_me (case_bndr' :| sc_args') @@ -3061,9 +3064,10 @@ mkCallUDs' env f args -- For "invisibleFunArg", which are the type-class dictionaries, -- we decide on a case by case basis if we want to specialise -- on this argument; if so, SpecDict, if not UnspecArg - mk_spec_arg arg (Anon pred af) + mk_spec_arg arg (Anon _pred af) | isInvisibleFunArg af - , interestingDict arg (scaledThing pred) + , interestingDict (ISE emptyInScopeSet realIdUnfolding) arg + -- , interestingDict arg (scaledThing pred) -- See Note [Interesting dictionary arguments] = SpecDict arg @@ -3169,33 +3173,47 @@ in the NonRec case of specBind. (This is too exotic to trouble with the Rec case.) -} -interestingDict :: CoreExpr -> Type -> Bool +-- interestingDict :: CoreExpr -> Type -> Bool +interestingDict :: InScopeEnv -> CoreExpr -> Bool -- A dictionary argument is interesting if it has *some* structure, -- see Note [Interesting dictionary arguments] -- NB: "dictionary" arguments include constraints of all sorts, -- including equality constraints; hence the Coercion case -- To make this work, we need to ensure that dictionaries have -- unfoldings in them. -interestingDict arg _arg_ty - -- No benefit to specalizing for a ~# b I believe - -- | (isEqPred arg_ty) = False - -- | - -- not (typeDeterminesValue arg_ty) = False -- See Note [Type determines value] - | otherwise = go arg - where - go (Var v) = hasSomeUnfolding (idUnfolding v) - || isDataConWorkId v - go (Type _) = False - go (Coercion _) = False - go (App fn (Type _)) = go fn - go (App fn (Coercion _)) = go fn - go (Tick _ a) = go a - go (Cast e _) = go e - go (Lit{}) = True - go (Case{}) = True - go (Let{}) = True - go (App{}) = True - go (Lam{}) = True +interestingDict env (Cast arg _) + = interestingDict env arg +interestingDict env arg + | Just (_, _, data_con, _tys, args) <- exprIsConApp_maybe env arg + , Just cls <- tyConClass_maybe (dataConTyCon data_con) + , (not . isIPLikePred) (exprType arg) + = if isCTupleClass cls + then any (interestingDict env) args + else True + | otherwise + = False + + +-- interestingDict arg _arg_ty +-- -- No benefit to specalizing for a ~# b I believe +-- -- | (isEqPred arg_ty) = False +-- -- | +-- -- not (typeDeterminesValue arg_ty) = False -- See Note [Type determines value] +-- | otherwise = go arg +-- where +-- go (Var v) = hasSomeUnfolding (idUnfolding v) +-- || isDataConWorkId v +-- go (Type _) = False +-- go (Coercion _) = False +-- go (App fn (Type _)) = go fn +-- go (App fn (Coercion _)) = go fn +-- go (Tick _ a) = go a +-- go (Cast e _) = go e +-- go (Lit{}) = True +-- go (Case{}) = True +-- go (Let{}) = True +-- go (App{}) = True +-- go (Lam{}) = True -- go _ = True View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9ec6b7572f3399c2033e718574eafc9… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9ec6b7572f3399c2033e718574eafc9… You're receiving this email because of your account on gitlab.haskell.org.

1 0