Simon Peyton Jones pushed to branch wip/T23109 at Glasgow Haskell Compiler / GHC Commits: 9186fc91 by Simon Peyton Jones at 2025-08-01T23:58:51+01:00 Wibbles - - - - - 1 changed file: - compiler/GHC/Core/Opt/Specialise.hs Changes: ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -1625,6 +1625,15 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs (rhs_bndrs, rhs_body) = collectBindersPushingCo rhs -- See Note [Account for casts in binding] + -- Copy InlinePragma information from the parent Id. + -- So if f has INLINE[1] so does spec_fn + spec_inl_prag + | not is_local -- See Note [Specialising imported functions] + , isStrongLoopBreaker (idOccInfo fn) -- in GHC.Core.Opt.OccurAnal + = neverInlinePragma + | otherwise + = inl_prag + not_in_scope :: InterestingVarFun not_in_scope v = isLocalVar v && not (v `elemInScopeSet` in_scope) @@ -1654,9 +1663,8 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs ; (useful, subst'', rule_bndrs, rule_lhs_args, spec_bndrs, dx_binds, spec_args) <- specHeader subst' rhs_bndrs all_call_args - ; (rule_bndrs, rule_lhs_args, spec_bndrs, spec_args) - <- return ( poly_qvars ++ rule_bndrs, rule_lhs_args - , poly_qvars ++ spec_bndrs, spec_args ) + ; let all_rule_bndrs = poly_qvars ++ rule_bndrs + env' = env { se_subst = subst'' } {- ; pprTrace "spec_call" (vcat @@ -1664,7 +1672,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs , text "call info: " <+> ppr _ci , text "poly_qvars: " <+> ppr poly_qvars , text "useful: " <+> ppr useful - , text "rule_bndrs:" <+> ppr rule_bndrs + , text "all_rule_bndrs:" <+> ppr all_rule_bndrs , text "rule_lhs_args:" <+> ppr rule_lhs_args , text "spec_bndrs:" <+> ppr spec_bndrs , text "dx_binds:" <+> ppr dx_binds @@ -1674,41 +1682,47 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs return () -} - ; let inner_rhs_bndrs = dropList all_call_args rhs_bndrs - env' = env { se_subst = subst'' } - (env'', inner_rhs_bndrs') = substBndrs env' inner_rhs_bndrs - - all_rules = rules_acc ++ existing_rules + -- Check for (a) usefulness and (b) not already covered + -- See (SC1) in Note [Specialisations already covered] + ; let all_rules = rules_acc ++ existing_rules -- all_rules: we look both in the rules_acc (generated by this invocation -- of specCalls), and in existing_rules (passed in to specCalls) ; if not useful -- No useful specialisation - || alreadyCovered env' rule_bndrs fn rule_lhs_args is_active all_rules - -- See (SC1) in Note [Specialisations already covered] + || alreadyCovered env' all_rule_bndrs fn rule_lhs_args is_active all_rules then return spec_acc else - do { -- Run the specialiser on the specialised RHS - (rhs_body', rhs_uds) <- specExpr env'' rhs_body - - -- Add the { d1' = dx1; d2' = dx2 } usage stuff - -- to the rhs_uds; see Note [Specialising Calls] - ; let all_spec_bndrs = spec_bndrs ++ inner_rhs_bndrs' - (spec_uds, dumped_dbs) = dumpUDs all_spec_bndrs (dx_binds `consDictBinds` rhs_uds) - spec_rhs = mkLams all_spec_bndrs $ - wrapDictBindsE dumped_dbs rhs_body' - spec_fn_ty = exprType spec_rhs + + -- Not useless, not already covered: make a specialised binding + do { let inner_rhs_bndrs = dropList all_call_args rhs_bndrs + (env'', inner_rhs_bndrs') = substBndrs env' inner_rhs_bndrs + + -- Run the specialiser on the specialised RHS + ; (rhs_body', rhs_uds) <- specExpr env'' rhs_body + + -- Make the RHS of the specialised function + ; let spec_rhs_bndrs = spec_bndrs ++ inner_rhs_bndrs' + (rhs_uds1, inner_dumped_dbs) = dumpUDs spec_rhs_bndrs rhs_uds + (rhs_uds2, outer_dumped_dbs) = dumpUDs poly_qvars (dx_binds `consDictBinds` rhs_uds1) + -- dx_binds comes from the arguments to the call, and so can mention + -- poly_qvars but no other local binders + spec_rhs = mkLams poly_qvars $ + wrapDictBindsE outer_dumped_dbs $ + mkLams spec_rhs_bndrs $ + wrapDictBindsE inner_dumped_dbs rhs_body' + rule_rhs_args = poly_qvars ++ spec_bndrs -- Maybe add a void arg to the specialised function, -- to avoid unlifted bindings -- See Note [Specialisations Must Be Lifted] -- C.f. GHC.Core.Opt.WorkWrap.Utils.needsVoidWorkerArg + + spec_fn_ty = exprType spec_rhs add_void_arg = isUnliftedType spec_fn_ty && not (isJoinId fn) - (spec_bndrs1, spec_rhs1, spec_fn_ty1) - | add_void_arg = ( voidPrimId : spec_bndrs + (rule_rhs_args1, spec_rhs1, spec_fn_ty1) + | add_void_arg = ( voidPrimId : rule_rhs_args , Lam voidArgId spec_rhs - , mkVisFunTyMany unboxedUnitTy spec_fn_ty) - | otherwise = (spec_bndrs, spec_rhs, spec_fn_ty) - - join_arity_decr = length rule_lhs_args - length spec_bndrs1 + , mkVisFunTyMany unboxedUnitTy spec_fn_ty ) + | otherwise = (rule_rhs_args, spec_rhs, spec_fn_ty) -------------------------------------- -- Add a suitable unfolding; see Note [Inline specialisations] @@ -1716,22 +1730,14 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs -- arguments, not forgetting to wrap the dx_binds around the outside (#22358) simpl_opts = initSimpleOpts dflags wrap_unf_body body = foldr (Let . db_bind) (body `mkApps` spec_args) dx_binds - spec_unf = specUnfolding simpl_opts spec_bndrs1 wrap_unf_body + spec_unf = specUnfolding simpl_opts rule_rhs_args1 wrap_unf_body rule_lhs_args fn_unf -------------------------------------- -- Adding arity information just propagates it a bit faster -- See Note [Arity decrease] in GHC.Core.Opt.Simplify - -- Copy InlinePragma information from the parent Id. - -- So if f has INLINE[1] so does spec_fn - arity_decr = count isValArg rule_lhs_args - count isId spec_bndrs1 - - spec_inl_prag - | not is_local -- See Note [Specialising imported functions] - , isStrongLoopBreaker (idOccInfo fn) -- in GHC.Core.Opt.OccurAnal - = neverInlinePragma - | otherwise - = inl_prag + join_arity_decr = length rule_lhs_args - length rule_rhs_args1 + arity_decr = count isValArg rule_lhs_args - count isId rule_rhs_args1 spec_fn_info = vanillaIdInfo `setArityInfo` max 0 (fn_arity - arity_decr) @@ -1758,10 +1764,8 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs text "SPEC" spec_rule = mkSpecRule dflags this_mod True inl_act - herald fn rule_bndrs rule_lhs_args - (mkVarApps (Var spec_fn) spec_bndrs1) - - spec_f_w_arity = spec_fn + herald fn all_rule_bndrs rule_lhs_args + (mkVarApps (Var spec_fn) rule_rhs_args1) _rule_trace_doc = vcat [ ppr fn <+> dcolon <+> ppr fn_type , ppr spec_fn <+> dcolon <+> ppr spec_fn_ty1 @@ -1772,9 +1776,9 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs ] ; -- pprTrace "spec_call: rule" _rule_trace_doc - return ( spec_rule : rules_acc - , (spec_f_w_arity, spec_rhs1) : pairs_acc - , spec_uds `thenUDs` uds_acc + return ( spec_rule : rules_acc + , (spec_fn, spec_rhs1) : pairs_acc + , rhs_uds2 `thenUDs` uds_acc ) } } alreadyCovered :: SpecEnv @@ -2550,7 +2554,8 @@ specHeader -- Specialised function helpers -- `$sf = \spec_bndrs. let { dx_binds } in <orig-rhs> spec_arg` - , [OutBndr] -- spec_bndrs: Binders for $sf. Subset of rule_bndrs. + , [OutBndr] -- spec_bndrs: Binders for $sf, and args for the RHS + -- of the RULE. Subset of rule_bndrs. , [DictBind] -- dx_binds: Auxiliary dictionary bindings , [OutExpr] -- spec_args: Specialised arguments for unfolding -- Same length as "Args for LHS of rule" @@ -2613,7 +2618,7 @@ specHeader subst (bndr:bndrs) (SpecDict dict_arg : args) ; let dx' = case dx_bind of { Nothing -> dx; Just d -> d : dx } ; pure ( True, subst3 -- Ha! A useful specialisation! - , bndr' : rule_bs, Var bndr' : rule_es + , bndr' : rule_bs, Var bndr' : rule_es , spec_bs, dx', spec_dict : spec_args ) } -- Finally, we don't want to specialise on this argument 'i': View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9186fc91c1d7f387f75d271717980a91... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9186fc91c1d7f387f75d271717980a91... You're receiving this email because of your account on gitlab.haskell.org.