recursion-ninja pushed to branch wip/fix-26670 at Glasgow Haskell Compiler / GHC Commits: f7d47d20 by Recursion Ninja at 2025-12-18T18:52:11-05:00 Reverting semantic changes where Arity was erroneously set to 0 - - - - - 17 changed files: - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Opt/WorkWrap.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Instance/Typeable.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Types/Arity.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/Id.hs - compiler/GHC/Types/Id/Info.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/InlinePragma.hs - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Outputable.hs Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -655,27 +655,39 @@ tryCastWorkerWrapper env _ _ bndr rhs -- All other bindings , text "rhs:" <+> ppr rhs ]) ; return (mkFloatBind env (NonRec bndr rhs)) } -mkCastWrapperInlinePrag :: forall p. IsPass p => InlinePragma (GhcPass p) -> InlinePragma (GhcPass p) +mkCastWrapperInlinePrag :: InlinePragma GhcRn -> InlinePragma GhcRn -- See Note [Cast worker/wrapper] -mkCastWrapperInlinePrag (InlinePragma { inl_ext = inTag, inl_inline = fn_inl, inl_act = fn_act, inl_rule = rule_info }) - = InlinePragma { inl_ext = outTag - , inl_inline = fn_inl -- See Note [Worker/wrapper for INLINABLE functions] - , inl_act = wrap_act -- See Note [Wrapper activation] - , inl_rule = rule_info } -- in GHC.Core.Opt.WorkWrap - -- RuleMatchInfo is (and must be) unaffected +mkCastWrapperInlinePrag prag = + -- Consider each field of the 'InlinePragma' constructor + -- and deterimine what is the appropriate definition for the + -- corresponding value used within a worker/wrapper. + -- + -- 1. 'inl_ext': Overwrite + setInlinePragmaArityAsNotExplicit prag + `setInlinePragmaSource` src_txt + -- + -- 2. 'inl_inline': *Preserve* + -- See Note [Worker/wrapper for INLINABLE functions] + -- in GHC.Core.Opt.WorkWrap + -- <SKIP> + -- + -- 3. 'inl_act': Conditionally Update + -- See Note [Wrapper activation] + -- in GHC.Core.Opt.WorkWrap + `setInlinePragmaActivation` wrap_act + -- + -- 4. 'inl_rule': *Preserve* + -- RuleMatchInfo is (and must be) unaffected + -- <SKIP> + -- + -- <DONE> where -- See Note [Wrapper activation] in GHC.Core.Opt.WorkWrap -- But simpler, because we don't need to disable during InitialPhase wrap_act | isNeverActive fn_act = activateDuringFinal | otherwise = fn_act - - srcTxt = SourceText $ fsLit "{-# INLINE" - - outTag = case ghcPass @p of - GhcPs -> inTag - GhcRn -> inTag { inl_ghcrn_src = srcTxt } - GhcTc -> inTag { inl_ghcrn_src = srcTxt } - + fn_act = inlinePragmaActivation prag + src_txt = SourceText $ fsLit "{-# INLINE" {- ********************************************************************* * * ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -44,7 +44,7 @@ import GHC.Data.Bag import GHC.Data.OrdList import GHC.Data.List.SetOps -import GHC.Hs.Extension ( GhcTc ) +import GHC.Hs.Extension ( GhcRn ) import GHC.Types.Basic import GHC.Types.Unique.Supply @@ -1639,6 +1639,16 @@ 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 :: InlinePragma GhcRn + 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) @@ -1754,20 +1764,9 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs -- See Note [Arity decrease] in GHC.Core.Opt.Simplify join_arity_decr = length rule_lhs_args - length rule_rhs_args1 arity_decr = count isValArg rule_lhs_args - count isId rule_rhs_args1 - arity = max 0 (fn_arity - arity_decr) - - -- Copy InlinePragma information from the parent Id. - -- So if f has INLINE[1] so does spec_fn - spec_inl_prag :: InlinePragma GhcTc - spec_inl_prag - | not is_local -- See Note [Specialising imported functions] - , isStrongLoopBreaker (idOccInfo fn) -- in GHC.Core.Opt.OccurAnal - = neverInlinePragma `setInlinePragmaArity` arity - | otherwise - = inl_prag `setInlinePragmaArity` arity spec_fn_info - = vanillaIdInfo `setArityInfo` arity + = vanillaIdInfo `setArityInfo` max 0 (fn_arity - arity_decr) `setInlinePragInfo` spec_inl_prag `setUnfoldingInfo` spec_unf ===================================== compiler/GHC/Core/Opt/WorkWrap.hs ===================================== @@ -22,7 +22,7 @@ import GHC.Core.SimpleOpt import GHC.Data.FastString -import GHC.Hs.Extension (GhcPass, GhcTc) +import GHC.Hs.Extension (GhcPass, GhcRn) import GHC.Types.Var import GHC.Types.Id @@ -834,7 +834,7 @@ mkWWBindPair ww_opts fn_id fn_info fn_args fn_body work_uniq div _ -> inl_act wrap_prag srcTxt = SourceText $ fsLit "{-# INLINE" - work_prag = InlinePragma { inl_ext = InlinePragmaGhcTag srcTxt arity + work_prag = InlinePragma { inl_ext = XInlinePragmaGhc srcTxt ArityNotExplicit , inl_inline = fn_inline_spec , inl_act = work_act , inl_rule = FunLike } @@ -883,7 +883,7 @@ mkWWBindPair ww_opts fn_id fn_info fn_args fn_body work_uniq div | otherwise = topDmd wrap_rhs = wrap_fn work_id - wrap_prag = mkStrWrapperInlinePrag fn_inl_prag fn_rules arity + wrap_prag = mkStrWrapperInlinePrag fn_inl_prag fn_rules wrap_unf = mkWrapperUnfolding simpl_opts wrap_rhs arity wrap_id = fn_id `setIdUnfolding` wrap_unf @@ -897,11 +897,11 @@ mkWWBindPair ww_opts fn_id fn_info fn_args fn_body work_uniq div fn_unfolding = realUnfoldingInfo fn_info fn_rules = ruleInfoRules (ruleInfo fn_info) -mkStrWrapperInlinePrag :: InlinePragma (GhcPass p) -> [CoreRule] -> Arity -> InlinePragma GhcTc +mkStrWrapperInlinePrag :: InlinePragma (GhcPass p) -> [CoreRule] -> InlinePragma GhcRn mkStrWrapperInlinePrag (InlinePragma { inl_inline = fn_inl , inl_act = fn_act - , inl_rule = rule_info }) rules arity - = InlinePragma { inl_ext = InlinePragmaGhcTag srcTxt arity + , inl_rule = rule_info }) rules + = InlinePragma { inl_ext = XInlinePragmaGhc srcTxt ArityNotExplicit , inl_inline = fn_inl -- See Note [Worker/wrapper for INLINABLE functions] ===================================== compiler/GHC/CoreToIface.hs ===================================== @@ -503,8 +503,7 @@ toIfaceIdInfo id_info ------------ Inline prag -------------- inline_prag = inlinePragInfo id_info inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing - | otherwise = Just . HsInline $ - inline_prag `setInlinePragmaArity` arity_info + | otherwise = Just (HsInline inline_prag) -------------------------- toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem ===================================== compiler/GHC/HsToCore/Binds.hs ===================================== @@ -324,8 +324,7 @@ dsAbsBinds dflags tyvars dicts exports -- No SpecPrags (no dicts) -- Can't be a default method (default methods are singletons) = do { dsHsWrapper wrap $ \core_wrap -> do - { return ( gbl_id `setInlinePragma` - (defaultInlinePragma `setInlinePragmaArity` 0) + { return ( gbl_id `setInlinePragma` defaultInlinePragma , core_wrap (Var lcl_id)) } } ; main_prs <- mapM mk_main exports ; let bind_prs' = map mk_aux_bind bind_prs @@ -370,8 +369,7 @@ dsAbsBinds dflags tyvars dicts exports mkVarApps (Var poly_tup_id) (tyvars ++ dicts) rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags - ; let global' = (global `setInlinePragma` - (defaultInlinePragma `setInlinePragmaArity` dictArity dicts)) + ; let global' = (global `setInlinePragma` defaultInlinePragma) `addIdSpecialisations` rules -- Kill the INLINE pragma because it applies to -- the user written (local) function. The global @@ -447,7 +445,7 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding' simpl_opts rhs, rhs) | otherwise - = case inl_spec of + = case inlinePragmaSpec inline_prag of NoUserInlinePrag -> (gbl_id, rhs) NoInline {} -> (gbl_id, rhs) Opaque {} -> (gbl_id, rhs) @@ -455,16 +453,21 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs Inline {} -> inline_pair where simpl_opts = initSimpleOpts dflags - InlinePragma (InlinePragmaGhcTag _ arity) inl_spec _ _ = idInlinePragma gbl_id + inline_prag = idInlinePragma gbl_id inlinable_unf = mkInlinableUnfolding simpl_opts StableUserSrc rhs - inline_pair = - -- Add an Unfolding for an INLINE (but not for NOINLINE) - -- And eta-expand the RHS; see Note [Eta-expanding INLINE things] - let real_arity = dict_arity + arity - -- NB: The arity passed to mkInlineUnfoldingWithArity - -- must take account of the dictionaries - in ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity simpl_opts StableUserSrc real_arity rhs - , etaExpand real_arity rhs) + inline_pair + | ArityExplicitly arity <- inlinePragmaArity inline_prag + -- Add an Unfolding for an INLINE (but not for NOINLINE) + -- And eta-expand the RHS; see Note [Eta-expanding INLINE things] + , let real_arity = dict_arity + fromEnum arity + -- NB: The arity passed to mkInlineUnfoldingWithArity + -- must take account of the dictionaries + = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity simpl_opts StableUserSrc real_arity rhs + , etaExpand real_arity rhs) + + | otherwise + = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $ + (gbl_id `setIdUnfolding` mkInlineUnfoldingNoArity simpl_opts StableUserSrc rhs, rhs) dictArity :: [Var] -> Arity -- Don't count coercion variables in arity @@ -1017,7 +1020,7 @@ dsSpec_help poly_nm poly_id poly_rhs spec_inl orig_bndrs ds_call fn_unf = realIdUnfolding poly_id spec_unf = specUnfolding simpl_opts spec_bndrs mk_spec_body rule_lhs_args fn_unf spec_info = vanillaIdInfo - `setInlinePragInfo` specFunInlinePrag poly_id id_inl spec_inl + `setInlinePragInfo` specFunInlinePrag poly_id id_inl (demoteInlinePragmaTc spec_inl) `setUnfoldingInfo` spec_unf spec_id = mkLocalVar (idDetails poly_id) spec_name ManyTy spec_ty spec_info -- Specialised binding is toplevel, hence Many. @@ -1057,7 +1060,7 @@ dsSpec_help poly_nm poly_id poly_rhs spec_inl orig_bndrs ds_call ; dsWarnOrphanRule rule ; case checkUselessSpecPrag poly_id rule_lhs_args spec_bndrs - no_act_spec (unsetInlinePragmaArity spec_inl) rule_act of + no_act_spec spec_inl rule_act of Nothing -> return (Just result) Just reason -> do { diagnosticDs $ DsUselessSpecialisePragma poly_nm is_dfun reason @@ -1111,7 +1114,7 @@ decomposeCall poly_id ds_call -- Is this SPECIALISE pragma useless? checkUselessSpecPrag :: Id -> [CoreExpr] - -> [Var] -> Bool -> InlinePragma GhcPs -> Activation + -> [Var] -> Bool -> InlinePragma (GhcPass p) -> Activation -> Maybe UselessSpecialisePragmaReason checkUselessSpecPrag poly_id rule_lhs_args spec_bndrs no_act_spec spec_inl rule_act @@ -1187,19 +1190,17 @@ getCastedVar (Var v) = Just (v, MRefl) getCastedVar (Cast (Var v) co) = Just (v, MCo co) getCastedVar _ = Nothing -specFunInlinePrag :: Id -> InlinePragma GhcTc - -> InlinePragma GhcTc -> InlinePragma GhcTc +--specFunInlinePrag :: forall p. IsPass p => Id -> InlinePragma (GhcPass p) -> InlinePragma (GhcPass p) -> InlinePragma (GhcPass p) +specFunInlinePrag :: Id -> InlinePragma GhcRn -> InlinePragma GhcRn -> InlinePragma GhcRn -- See Note [Activation pragmas for SPECIALISE] specFunInlinePrag poly_id id_inl spec_inl | not (isDefaultInlinePragma spec_inl) = spec_inl | isGlobalId poly_id -- See Note [Specialising imported functions] -- in OccurAnal - , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma `setInlinePragmaArity` arity + , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma | otherwise = id_inl -- Get the INLINE pragma from SPECIALISE declaration, or, -- failing that, from the original Id - where - arity = arityInfo $ idInfo poly_id dsWarnOrphanRule :: CoreRule -> DsM () dsWarnOrphanRule rule ===================================== compiler/GHC/Rename/Bind.hs ===================================== @@ -1103,7 +1103,7 @@ renameSig ctxt sig@(SpecSig _ v tys inl) TopSigCtxt {} -> lookupLocatedOccRn WL_TermVariable v _ -> lookupSigOccRn ctxt sig v ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys - ; return (SpecSig noAnn new_v new_ty (inl `setInlinePragmaArity` 0), fvs) } -- TODO: setting arity to 0 is likely wrong + ; return (SpecSig noAnn new_v new_ty (setInlinePragmaArityAsNotExplicit inl), fvs) } where do_one (tys,fvs) ty = do { (new_ty, fvs_ty) <- rnHsSigType (SpecialiseSigCtx v) TypeLevel ty @@ -1114,11 +1114,11 @@ renameSig _ctxt (SpecSigE _ bndrs spec_e inl) ; fn_name <- lookupOccRn WL_TermVariable fn_rdr -- Checks that the head isn't forall-bound ; bindRuleBndrs (SpecECtx fn_rdr) bndrs $ \_ bndrs' -> do { (spec_e', fvs) <- rnLExpr spec_e - ; return (SpecSigE fn_name bndrs' spec_e' ( inl `setInlinePragmaArity` 0), fvs) } } -- TODO: setting arity to 0 is likely wrong + ; return (SpecSigE fn_name bndrs' spec_e' (setInlinePragmaArityAsNotExplicit inl), fvs) } } renameSig ctxt sig@(InlineSig _ v s) = do { new_v <- lookupSigOccRn ctxt sig v - ; return (InlineSig noAnn new_v ( s `setInlinePragmaArity` 0 ), emptyFVs) } -- TODO: setting arity to 0 is likely wrong + ; return (InlineSig noAnn new_v (setInlinePragmaArityAsNotExplicit s), emptyFVs) } renameSig ctxt (FixSig _ fsig) = do { new_fsig <- rnSrcFixityDecl ctxt fsig ===================================== compiler/GHC/Tc/Gen/Sig.hs ===================================== @@ -604,7 +604,7 @@ addInlinePragArity _ sig = sig add_inl_arity :: Arity -> InlinePragma GhcRn -> InlinePragma GhcRn add_inl_arity ar prag@(InlinePragma { inl_inline = inl_spec }) | Inline {} <- inl_spec -- Add arity only for real INLINE pragmas, not INLINABLE - = prag `setInlinePragmaArity` ar + = prag `setInlinePragmaArityAsExplicitly` ar | otherwise = prag @@ -620,7 +620,7 @@ addInlinePrags poly_id prags_for_me | inl@(L _ prag) : inls <- inl_prags = do { traceTc "addInlinePrag" (ppr poly_id $$ ppr prag) ; unless (null inls) (warn_multiple_inlines inl inls) - ; return (poly_id `setInlinePragma` prag) } + ; return (poly_id `setInlinePragma` demoteInlinePragmaTc prag) } | otherwise = return poly_id where ===================================== compiler/GHC/Tc/Instance/Typeable.hs ===================================== @@ -13,7 +13,7 @@ import GHC.Prelude import GHC.Platform import GHC.Types.Basic ( TypeOrConstraint(..) ) -import GHC.Types.InlinePragma ( neverInlinePragma, setInlinePragmaArity ) +import GHC.Types.InlinePragma ( neverInlinePragma ) import GHC.Types.SourceText ( SourceText(..) ) import GHC.Iface.Env( newGlobalBinder ) import GHC.Core.TyCo.Rep( Type(..), TyLit(..) ) @@ -554,8 +554,7 @@ getKindRep stuff@(Stuff {..}) in_scope = go | otherwise = do -- Place a NOINLINE pragma on KindReps since they tend to be quite -- large and bloat interface files. - let prag = neverInlinePragma `setInlinePragmaArity` 0 - rep_bndr <- (`setInlinePragma` prag) + rep_bndr <- (`setInlinePragma` neverInlinePragma) <$> newSysLocalId (fsLit "$krep") ManyTy (mkTyConTy kindRepTyCon) -- do we need to tie a knot here? ===================================== compiler/GHC/Tc/TyCl/Instance.hs ===================================== @@ -70,7 +70,6 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Basic import GHC.Types.Id -import GHC.Types.Id.Info (arityInfo) import GHC.Types.InlinePragma import GHC.Types.SourceFile import GHC.Types.SourceText @@ -1429,10 +1428,9 @@ addDFunPrags :: DFunId -> [Id] -> DFunId -- is messing with. addDFunPrags dfun_id sc_meth_ids = dfun_id `setIdUnfolding` mkDFunUnfolding dfun_bndrs dict_con dict_args - `setInlinePragma` (dfunInlinePragma `setInlinePragmaArity` arity) -- NOTE: Check if this arity calculation is correct + `setInlinePragma` dfunInlinePragma -- NB: mkDFunUnfolding takes care of unary classes where - arity = length var_apps dict_args = map Type inst_tys ++ var_apps var_apps = [mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids] @@ -2267,7 +2265,7 @@ mkDefMethBind loc dfun_id clas sel_id dm_name dm_spec = do { logger <- getLogger ; dm_id <- tcLookupId dm_name ; let inline_prag :: InlinePragma GhcRn - inline_prag = demoteInlinePragmaRn $ idInlinePragma dm_id + inline_prag = idInlinePragma dm_id inline_prags | isAnyInlinePragma inline_prag = [noLocA (InlineSig noAnn fn inline_prag)] | otherwise @@ -2669,11 +2667,9 @@ tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags }) tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag tcSpecInst dfun_id prag@(SpecInstSig _ hs_ty) = addErrCtxt (SpecPragmaCtxt prag) $ - let arity = arityInfo $ idInfo dfun_id - prag = defaultInlinePragma `setInlinePragmaArity` arity - in do { spec_dfun_ty <- tcHsClsInstType SpecInstCtxt hs_ty - ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty - ; return (SpecPrag dfun_id co_fn prag) } + do { spec_dfun_ty <- tcHsClsInstType SpecInstCtxt hs_ty + ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty + ; return (SpecPrag dfun_id co_fn defaultInlinePragma) } tcSpecInst _ _ = panic "tcSpecInst" ===================================== compiler/GHC/Types/Arity.hs ===================================== @@ -6,14 +6,18 @@ module GHC.Types.Arity ( Arity - , VisArity - , RepArity - , JoinArity , FullArgCount + , InlineArity(..) + , JoinArity + , RepArity + , VisArity ) where import GHC.Prelude +import Control.DeepSeq (NFData(..)) +import Data.Data (Data) + {- ************************************************************************ * * @@ -29,9 +33,29 @@ import GHC.Prelude -- See also Note [Definition of arity] in "GHC.Core.Opt.Arity" type Arity = Int --- | Syntactic (visibility) arity, i.e. the number of visible arguments. --- See Note [Visibility and arity] -type VisArity = Int +-- | FullArgCount is the number of type or value arguments in an application, +-- or the number of type or value binders in a lambda. Note: it includes +-- both type and value arguments! +type FullArgCount = Int + +-- | The arity /at which to/ inline a function. +-- This may differ from the function's syntactic arity. +data InlineArity + = ArityExplicitly !Word + -- ^ Inline only when applied to @n@ explicit + -- (non-type, non-dictionary) arguments. + -- + -- That is, 'ArityExplicitly' describes the number of + -- *source-code* arguments the thing must be applied to. + | ArityNotExplicit + -- ^ There does not exist an explicit number of arguments + -- that the inlining process should be applied to. + deriving (Eq, Data) + +instance NFData InlineArity where + + rnf (ArityExplicitly !w) = rnf w `seq` () + rnf !ArityNotExplicit = () -- | Representation Arity -- @@ -48,10 +72,9 @@ type RepArity = Int -- are counted. type JoinArity = Int --- | FullArgCount is the number of type or value arguments in an application, --- or the number of type or value binders in a lambda. Note: it includes --- both type and value arguments! -type FullArgCount = Int +-- | Syntactic (visibility) arity, i.e. the number of visible arguments. +-- See Note [Visibility and arity] +type VisArity = Int {- Note [Visibility and arity] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Types/Basic.hs ===================================== @@ -1304,18 +1304,18 @@ failed Succeeded = False failed Failed = True {- -data InlinePragmaGhcTag = InlinePragmaGhcTag +data XInlinePragmaGhc = XInlinePragmaGhc { inl_ghcrn_src :: {-# UNPACK#-} !SourceText , inl_ghcrn_arity :: {-# UNPACK#-} !Arity } deriving (Eq, Data) -instance NFData InlinePragmaGhcTag where - rnf (InlinePragmaGhcTag s a) = rnf s `seq` rnf a `seq` () +instance NFData XInlinePragmaGhc where + rnf (XInlinePragmaGhc s a) = rnf s `seq` rnf a `seq` () type instance XInlinePragma GhcPs = SourceText -type instance XInlinePragma GhcRn = InlinePragmaGhcTag -type instance XInlinePragma GhcTc = InlinePragmaGhcTag +type instance XInlinePragma GhcRn = XInlinePragmaGhc +type instance XInlinePragma GhcTc = XInlinePragmaGhc type instance XXInlinePragma (GhcPass _) = DataConCantHappen defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma @@ -1339,7 +1339,7 @@ dfunInlinePragma = defaultInlinePragma { inl_act = AlwaysActive setInlinePragmaArity :: InlinePragma GhcPs -> Arity -> InlinePragma GhcTc setInlinePragmaArity prag@(InlinePragma { inl_ext = srcTxt }) arity = - prag { inl_ext = InlinePragmaGhcTag srcTxt arity } + prag { inl_ext = XInlinePragmaGhc srcTxt arity } inlinePragmaSource :: forall p. IsPass p => InlinePragma (GhcPass p) -> SourceText ===================================== compiler/GHC/Types/Id.hs ===================================== @@ -150,7 +150,7 @@ import GHC.Core.DataCon import GHC.Core.Class import GHC.Core.Multiplicity -import GHC.Hs.Extension (GhcTc) +import GHC.Hs.Extension (GhcRn) import GHC.Types.RepType import GHC.Types.Demand @@ -944,13 +944,13 @@ The inline pragma tells us to be very keen to inline this Id, but it's still OK not to if optimisation is switched off. -} -idInlinePragma :: Id -> InlinePragma GhcTc +idInlinePragma :: Id -> InlinePragma GhcRn idInlinePragma id = inlinePragInfo (idInfo id) -setInlinePragma :: Id -> InlinePragma GhcTc -> Id +setInlinePragma :: Id -> InlinePragma GhcRn -> Id setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id -modifyInlinePragma :: Id -> (InlinePragma GhcTc -> InlinePragma GhcTc) -> Id +modifyInlinePragma :: Id -> (InlinePragma GhcRn -> InlinePragma GhcRn) -> Id modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id idInlineActivation :: Id -> Activation ===================================== compiler/GHC/Types/Id/Info.hs ===================================== @@ -106,10 +106,8 @@ import GHC.Unit.Module import GHC.Types.Demand import GHC.Types.Cpr import GHC.Types.InlinePragma -import GHC.Types.SourceText import {-# SOURCE #-} GHC.Tc.Utils.TcType ( ConcreteTyVars, noConcreteTyVars ) - import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Stg.EnforceEpt.TagSig @@ -441,7 +439,7 @@ data IdInfo -- See Note [Specialisations and RULES in IdInfo] realUnfoldingInfo :: Unfolding, -- ^ The 'Id's unfolding - inlinePragInfo :: InlinePragma GhcTc, + inlinePragInfo :: InlinePragma GhcRn, -- ^ Any inline pragma attached to the 'Id' occInfo :: OccInfo, -- ^ How the 'Id' occurs in the program @@ -554,16 +552,9 @@ tagSigInfo = tagSig setRuleInfo :: IdInfo -> RuleInfo -> IdInfo setRuleInfo info sp = sp `seq` info { ruleInfo = sp } ---setInlinePragInfo :: IdInfo -> InlinePragma GhcTc -> IdInfo ---setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr } -setInlinePragInfo :: forall p. IsPass p => IdInfo -> InlinePragma (GhcPass p) -> IdInfo -setInlinePragInfo info pr@(InlinePragma { inl_ext = src }) = pr `seq` info { inlinePragInfo = pr { inl_ext = tag } } - where - tag :: InlinePragmaGhcTag - tag = case ghcPass @p of - GhcPs -> InlinePragmaGhcTag (src :: SourceText) 0 - GhcRn -> (src :: InlinePragmaGhcTag) - GhcTc -> (src :: InlinePragmaGhcTag) + +setInlinePragInfo :: IdInfo -> InlinePragma GhcRn -> IdInfo +setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr } setOccInfo :: IdInfo -> OccInfo -> IdInfo setOccInfo info oc = oc `seq` info { occInfo = oc } @@ -630,7 +621,7 @@ vanillaIdInfo = IdInfo { ruleInfo = emptyRuleInfo, realUnfoldingInfo = noUnfolding, - inlinePragInfo = defaultInlinePragma `setInlinePragmaArity` 0, + inlinePragInfo = defaultInlinePragma, occInfo = noOccInfo, demandInfo = topDmd, dmdSigInfo = nopSig, ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -65,7 +65,7 @@ import GHC.Core.TyCon import GHC.Core.Class import GHC.Core.DataCon -import GHC.Hs.Extension (GhcPs, GhcTc) +import GHC.Hs.Extension (GhcRn) import GHC.Types.Literal import GHC.Types.RepType ( countFunRepArgs, typePrimRep ) @@ -608,8 +608,8 @@ mkDataConWorkId wkr_name data_con -- See Note [Strict fields in Core] `setLFInfo` wkr_lf_info - wkr_inline_prag :: InlinePragma GhcTc - wkr_inline_prag = alwaysInlineConLikePragma `setInlinePragmaArity` wkr_arity + wkr_inline_prag :: InlinePragma GhcRn + wkr_inline_prag = alwaysInlineConLikePragma wkr_arity = dataConRepArity data_con wkr_sig = mkClosedDmdSig wkr_dmds topDiv @@ -989,7 +989,7 @@ mkDataConRep dc_bang_opts fam_envs wrap_name data_con ; return (unbox_fn expr) } -dataConWrapperInlinePragma :: InlinePragma GhcPs +dataConWrapperInlinePragma :: InlinePragma GhcRn -- See Note [DataCon wrappers are conlike] dataConWrapperInlinePragma = alwaysInlineConLikePragma @@ -1950,7 +1950,7 @@ nullAddrId :: Id -- a way to write this literal in Haskell. nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info where - info = noCafIdInfo `setInlinePragInfo` (alwaysInlinePragma `setInlinePragmaArity` 0 :: InlinePragma GhcTc) + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` mkCompulsoryUnfolding (Lit nullAddrLit) ------------------------------------------------ ===================================== compiler/GHC/Types/InlinePragma.hs ===================================== @@ -6,7 +6,7 @@ (c) The GRASP/AQUA Project, Glasgow University, 1997-1998 -} -{-# OPTIONS_GHC -Wno-orphans #-} -- Binary InlinePragmaGhcTag, Binary InlinePragma +{-# OPTIONS_GHC -Wno-orphans #-} -- Binary XInlinePragmaGhc, Binary InlinePragma module GHC.Types.InlinePragma ( -- * Inline Pragma Encoding @@ -21,6 +21,7 @@ module GHC.Types.InlinePragma , neverInlinePragma -- *** Field accessors , inlinePragmaActivation + , inlinePragmaArity , inlinePragmaName , inlinePragmaRuleMatchInfo , inlinePragmaSource @@ -33,20 +34,22 @@ module GHC.Types.InlinePragma , isNoInlinePragma , isOpaquePragma -- *** Mutators + , setInlinePragmaSource + , setInlinePragmaArityAsExplicitly + , setInlinePragmaArityAsNotExplicit , setInlinePragmaActivation - , setInlinePragmaArity + , setInlinePragmaSpec , setInlinePragmaRuleMatchInfo -- *** GHC pass conversions - , demoteInlinePragmaRn + , demoteInlinePragmaTc , promoteInlinePragmaRn - , setInlinePragmaTag - , unsetInlinePragmaArity -- *** Pretty-printing , pprInline , pprInlineDebug -- ** Extensible record type for GhcRn & GhcTc - , InlinePragmaGhcTag(..) + , XInlinePragmaGhc(..) + , InlineArity(..) -- ** InlineSpec -- *** Data-type @@ -98,19 +101,26 @@ import {-# SOURCE #-} GHC.Hs.Extension import GHC.Data.FastString import GHC.Utils.Binary import GHC.Utils.Outputable -import GHC.Types.Arity (Arity) -import GHC.Types.SourceText +import GHC.Types.Arity (InlineArity(..)) +import GHC.Types.SourceText (SourceText(..)) import Control.DeepSeq (NFData(..)) -import Data.Data +import Data.Data (Data) import Language.Haskell.Syntax.Binds.InlinePragma import Language.Haskell.Syntax.Extension +-- infixl so you can say (prag `set` a `set` b) +infixl 1 `setInlinePragmaActivation`, + `setInlinePragmaArityAsExplicitly`, + `setInlinePragmaRuleMatchInfo`, + `setInlinePragmaSource`, + `setInlinePragmaSpec` + data XInlinePragmaGhc = XInlinePragmaGhc { xinl_src :: SourceText -- ^ See Note [Pragma source text] - , xinl_sat :: Maybe Arity - -- ^ @Just n@ <=> Inline only when applied to @n@ explicit + , xinl_sat :: InlineArity + -- ^ Inline only when applied to @n@ explicit -- (non-type, non-dictionary) arguments. -- -- That is, 'xinl_sat' describes the number of *source-code* @@ -120,33 +130,48 @@ data XInlinePragmaGhc = XInlinePragmaGhc } deriving (Eq, Data) -instance NFData InlinePragmaGhcTag where - rnf (InlinePragmaGhcTag s a) = rnf s `seq` rnf a `seq` () +instance NFData XInlinePragmaGhc where + rnf (XInlinePragmaGhc s a) = rnf s `seq` rnf a `seq` () type instance XInlinePragma GhcPs = SourceText -type instance XInlinePragma GhcRn = InlinePragmaGhcTag -type instance XInlinePragma GhcTc = InlinePragmaGhcTag +type instance XInlinePragma GhcRn = XInlinePragmaGhc +type instance XInlinePragma GhcTc = XInlinePragmaGhc type instance XXInlinePragma (GhcPass _) = DataConCantHappen -defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma - :: InlinePragma GhcPs -defaultInlinePragma = InlinePragma { inl_ext = SourceText $ fsLit "{-# INLINE" - , inl_act = AlwaysActive - , inl_rule = FunLike - , inl_inline = NoUserInlinePrag } - -alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline } -neverInlinePragma = defaultInlinePragma { inl_act = NeverActive } - -alwaysInlineConLikePragma :: InlinePragma GhcPs -alwaysInlineConLikePragma = alwaysInlinePragma { inl_rule = ConLike } +-- | The default 'InlinePragma' definition for GHC. +-- The type and value of 'inl_ext' provided will differ +-- between the passes of GHC. Consequently, it may be +-- necessary to apply type annotation at the call site +-- to help the type checker disambiguate the correct +-- type of 'inl_ext'. +defaultInlinePragma :: forall p. IsPass p => InlinePragma (GhcPass p) +defaultInlinePragma = + let srcTxt = SourceText $ fsLit "{-# INLINE" + inlExt = case ghcPass @p of + GhcPs -> srcTxt + GhcRn -> XInlinePragmaGhc srcTxt ArityNotExplicit + GhcTc -> XInlinePragmaGhc srcTxt ArityNotExplicit + in InlinePragma + { inl_ext = inlExt + , inl_act = AlwaysActive + , inl_rule = FunLike + , inl_inline = NoUserInlinePrag } + +-- | The default 'InlinePragma' definition for the "parser pass" of GHC. +alwaysInlinePragma, neverInlinePragma, alwaysInlineConLikePragma, dfunInlinePragma + :: forall p. IsPass p => InlinePragma (GhcPass p) + + +alwaysInlinePragma = (defaultInlinePragma @p) { inl_inline = Inline } +neverInlinePragma = (defaultInlinePragma @p) { inl_act = NeverActive } +alwaysInlineConLikePragma = (alwaysInlinePragma @p) { inl_rule = ConLike } -- A DFun has an always-active inline activation so that -- exprIsConApp_maybe can "see" its unfolding -- (However, its actual Unfolding is a DFunUnfolding, which is -- never inlined other than via exprIsConApp_maybe.) -dfunInlinePragma = defaultInlinePragma { inl_act = AlwaysActive - , inl_rule = ConLike } +dfunInlinePragma = (defaultInlinePragma @p) { inl_act = AlwaysActive + , inl_rule = ConLike } isDefaultInlinePragma :: InlinePragma p -> Bool isDefaultInlinePragma (XInlinePragma _) = False @@ -155,28 +180,38 @@ isDefaultInlinePragma (InlinePragma { inl_act = activation , inl_inline = inline }) = noUserInlineSpec inline && isAlwaysActive activation && isFunLike match_info -setInlinePragmaArity :: forall p q. (IsPass p, XInlinePragma (GhcPass q) ~ InlinePragmaGhcTag) - => InlinePragma (GhcPass p) -> Arity -> InlinePragma (GhcPass q) +setInlinePragmaArity :: forall p q. (IsPass p, XInlinePragma (GhcPass q) ~ XInlinePragmaGhc) + => InlinePragma (GhcPass p) -> InlineArity -> InlinePragma (GhcPass q) setInlinePragmaArity prag arity = - prag { inl_ext = InlinePragmaGhcTag (inlinePragmaSource prag) arity } + prag { inl_ext = XInlinePragmaGhc (inlinePragmaSource prag) arity } + +setInlinePragmaArityAsExplicitly :: forall a p q. (Integral a, IsPass p, XInlinePragma (GhcPass q) ~ XInlinePragmaGhc) + => InlinePragma (GhcPass p) -> a -> InlinePragma (GhcPass q) +setInlinePragmaArityAsExplicitly prag intVal = prag `setInlinePragmaArity` arity + where + arity = ArityExplicitly . fromIntegral $ abs intVal -unsetInlinePragmaArity :: forall p. IsPass p => InlinePragma (GhcPass p) -> InlinePragma GhcPs -unsetInlinePragmaArity prag = - prag { inl_ext = inlinePragmaSource prag } +setInlinePragmaArityAsNotExplicit :: forall p q. (IsPass p, XInlinePragma (GhcPass q) ~ XInlinePragmaGhc) + => InlinePragma (GhcPass p) -> InlinePragma (GhcPass q) +setInlinePragmaArityAsNotExplicit = flip setInlinePragmaArity ArityNotExplicit inlinePragmaSource :: forall p. IsPass p => InlinePragma (GhcPass p) -> SourceText inlinePragmaSource (InlinePragma { inl_ext = src }) = srcTxt where srcTxt = case ghcPass @p of GhcPs -> src - GhcRn -> inl_ghcrn_src src - GhcTc -> inl_ghcrn_src src + GhcRn -> xinl_src src + GhcTc -> xinl_src src + +inlinePragmaArity :: forall p. (XInlinePragma (GhcPass p) ~ XInlinePragmaGhc) + => InlinePragma (GhcPass p) -> InlineArity +inlinePragmaArity = xinl_sat . inl_ext promoteInlinePragmaRn :: InlinePragma GhcRn -> InlinePragma GhcTc promoteInlinePragmaRn prag@(InlinePragma { inl_ext = src }) = prag { inl_ext = src } -demoteInlinePragmaRn :: InlinePragma GhcTc -> InlinePragma GhcRn -demoteInlinePragmaRn prag@(InlinePragma { inl_ext = src }) = prag { inl_ext = src } +demoteInlinePragmaTc :: InlinePragma GhcTc -> InlinePragma GhcRn +demoteInlinePragmaTc prag@(InlinePragma { inl_ext = src }) = prag { inl_ext = src } inlinePragmaSpec :: InlinePragma p -> InlineSpec inlinePragmaSpec = inl_inline @@ -187,8 +222,18 @@ inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation inlinePragmaRuleMatchInfo :: InlinePragma (GhcPass p) -> RuleMatchInfo inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info -setInlinePragmaTag :: InlinePragma (GhcPass p) -> XInlinePragma (GhcPass q) -> InlinePragma (GhcPass q) -setInlinePragmaTag prag tag = prag { inl_ext = tag } +setInlinePragmaSource :: forall p. IsPass p + => InlinePragma (GhcPass p) -> SourceText -> InlinePragma (GhcPass p) +setInlinePragmaSource prag srcTxt = prag { inl_ext = newExt } + where + oldExt = inl_ext prag + newExt = case ghcPass @p of + GhcPs -> srcTxt + GhcRn -> oldExt { xinl_src = srcTxt } + GhcTc -> oldExt { xinl_src = srcTxt } + +setInlinePragmaSpec :: InlinePragma (GhcPass p) -> InlineSpec -> InlinePragma (GhcPass p) +setInlinePragmaSpec prag spec = prag { inl_inline = spec } setInlinePragmaActivation :: InlinePragma (GhcPass p) -> Activation -> InlinePragma (GhcPass p) setInlinePragmaActivation prag activation = prag { inl_act = activation } @@ -360,15 +405,15 @@ no harm. modules once TTG has progressed and the Language.Haskell.Syntax.Types module no longer depends on importing GHC.Hs.Doc. -} -instance Binary InlinePragmaGhcTag where - put_ bh (InlinePragmaGhcTag s a) = do +instance Binary XInlinePragmaGhc where + put_ bh (XInlinePragmaGhc s a) = do put_ bh s put_ bh a get bh = do s <- get bh a <- get bh - return (InlinePragmaGhcTag s a) + return (XInlinePragmaGhc s a) instance forall p. IsPass p => Binary (InlinePragma (GhcPass p)) where put_ bh (InlinePragma s a b c) = do ===================================== compiler/GHC/Utils/Binary.hs ===================================== @@ -125,6 +125,7 @@ import GHC.Data.FastString import GHC.Data.TrieMap import GHC.Utils.Exception import GHC.Utils.Panic.Plain +import GHC.Types.Arity (InlineArity(..)) import GHC.Types.Unique.FM import GHC.Data.FastMutInt import GHC.Utils.Fingerprint @@ -2064,28 +2065,21 @@ instance Binary FFIType where FFIUInt64 -> 11 instance Binary Activation where - put_ bh NeverActive = - putByte bh 0 - put_ bh FinalActive = do - putByte bh 1 - put_ bh AlwaysActive = - putByte bh 2 - put_ bh (ActiveBefore aa) = do - putByte bh 3 - put_ bh aa - put_ bh (ActiveAfter ab) = do - putByte bh 4 - put_ bh ab + put_ bh = \case + NeverActive -> putByte bh 0 + FinalActive -> putByte bh 1 + AlwaysActive -> putByte bh 2 + ActiveBefore aa -> putByte bh 3 *> put_ bh aa + ActiveAfter ab -> putByte bh 4 *> put_ bh ab + get bh = do - h <- getByte bh - case h of - 0 -> return NeverActive - 1 -> return FinalActive - 2 -> return AlwaysActive - 3 -> do aa <- get bh - return (ActiveBefore aa) - _ -> do ab <- get bh - return (ActiveAfter ab) + h <- getByte bh + case h of + 0 -> pure NeverActive + 1 -> pure FinalActive + 2 -> pure AlwaysActive + 3 -> ActiveBefore <$> get bh + _ -> ActiveAfter <$> get bh instance Binary InlineSpec where put_ bh = putByte bh . \case @@ -2095,18 +2089,29 @@ instance Binary InlineSpec where NoInline -> 3 Opaque -> 4 - get bh = do h <- getByte bh - return $ case h of - 0 -> NoUserInlinePrag - 1 -> Inline - 2 -> Inlinable - 3 -> NoInline - _ -> Opaque + get bh = do + h <- getByte bh + return $ case h of + 0 -> NoUserInlinePrag + 1 -> Inline + 2 -> Inlinable + 3 -> NoInline + _ -> Opaque instance Binary RuleMatchInfo where put_ bh FunLike = putByte bh 0 put_ bh ConLike = putByte bh 1 + + get bh = do + h <- getByte bh + if h == 1 then pure ConLike + else pure FunLike + +instance Binary InlineArity where + put_ bh ArityNotExplicit = putByte bh 0 + put_ bh (ArityExplicitly w) = putByte bh 1 *> put_ bh w + get bh = do - h <- getByte bh - if h == 1 then return ConLike - else return FunLike + h <- getByte bh + if h == 0 then pure ArityNotExplicit + else ArityExplicitly <$> get bh ===================================== compiler/GHC/Utils/Outputable.hs ===================================== @@ -112,6 +112,7 @@ module GHC.Utils.Outputable ( ) where import Language.Haskell.Syntax.Binds.InlinePragma +import Language.Haskell.Syntax.Extension ( dataConCantHappen ) import Language.Haskell.Syntax.Module.Name ( ModuleName(..) ) import {-# SOURCE #-} GHC.Hs.Extension @@ -2025,7 +2026,15 @@ pprInlineDebug = pprInline' False pprInline' :: Bool -- True <=> do not display the inl_inline field -> InlinePragma (GhcPass p) -> SDoc -pprInline' _ (XInlinePragma ext) = dataConCantHappen ext +-- TODO: Revise this definition for XInlinePragma constructor. +-- The proper defintion is: +-- > pprInline' _ (XInlinePragma ext) = dataConCantHappen ext +-- We cannot add this proper definition until this module imports +-- 'GHC.Types.InlinePragma', instead of the other way around. +-- Until then, the type family definition of XInlinePragma (GhcPass _) +-- will not be in scope and the type-checker cannot determine that +-- the binding 'ext' is in fact a 'DataConCantHappen' value. +pprInline' _ (XInlinePragma ext) = error "XInlinePragma = dataConCantHappen" pprInline' emptyInline (InlinePragma { inl_inline = inline, inl_act = activation, View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f7d47d203034f014791a2aa2cfb8fd22... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f7d47d203034f014791a2aa2cfb8fd22... You're receiving this email because of your account on gitlab.haskell.org.