recursion-ninja pushed to branch wip/fix-26670 at Glasgow Haskell Compiler / GHC Commits: f0e98a45 by Recursion Ninja at 2025-12-17T14:43:49-05:00 Correcting some suspicious bits of code, removing dead code - - - - - 15 changed files: - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/WorkWrap.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/Id/Info.hs - compiler/GHC/Types/InlinePragma.hs - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Outputable.hs - compiler/Language/Haskell/Syntax/Binds.hs - compiler/Language/Haskell/Syntax/Binds/InlinePragma.hs Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -657,8 +657,8 @@ tryCastWorkerWrapper env _ _ bndr rhs -- All other bindings mkCastWrapperInlinePrag :: forall p. IsPass p => InlinePragma (GhcPass p) -> InlinePragma (GhcPass p) -- See Note [Cast worker/wrapper] -mkCastWrapperInlinePrag (InlinePragma { inl_src = inTag, inl_inline = fn_inl, inl_act = fn_act, inl_rule = rule_info }) - = InlinePragma { inl_src = outTag +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 ===================================== compiler/GHC/Core/Opt/WorkWrap.hs ===================================== @@ -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_src = InlinePragmaGhcTag srcTxt arity + work_prag = InlinePragma { inl_ext = InlinePragmaGhcTag srcTxt arity , inl_inline = fn_inline_spec , inl_act = work_act , inl_rule = FunLike } @@ -901,7 +901,7 @@ mkStrWrapperInlinePrag :: InlinePragma (GhcPass p) -> [CoreRule] -> Arity -> Inl mkStrWrapperInlinePrag (InlinePragma { inl_inline = fn_inl , inl_act = fn_act , inl_rule = rule_info }) rules arity - = InlinePragma { inl_src = InlinePragmaGhcTag srcTxt arity + = InlinePragma { inl_ext = InlinePragmaGhcTag srcTxt arity , inl_inline = fn_inl -- See Note [Worker/wrapper for INLINABLE functions] ===================================== compiler/GHC/Hs/Binds.hs ===================================== @@ -819,26 +819,20 @@ ppr_sig (ClassOpSig _ is_deflt vars ty) | otherwise = pprVarSig (map unLoc vars) (ppr ty) ppr_sig (FixSig _ fix_sig) = ppr fix_sig -ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_src = src, inl_inline = spec })) +ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_inline = spec })) = pragSrcBrackets srcTxt pragmaSrc $ pprSpec (unLoc var) (interpp'SP ty) inl - where - srcTxt = case ghcPass @p of - GhcPs -> src - GhcRn -> inl_ghcrn_src src - GhcTc -> inl_ghcrn_src src - pragmaSrc = case spec of - NoUserInlinePrag -> "{-# " ++ extractSpecPragName srcTxt - _ -> "{-# " ++ extractSpecPragName srcTxt ++ "_INLINE" - -ppr_sig (SpecSigE _ bndrs spec_e inl@(InlinePragma { inl_src = src, inl_inline = spec })) + where + srcTxt = inlinePragmaSource inl + pragmaSrc = case spec of + NoUserInlinePrag -> "{-# " ++ extractSpecPragName srcTxt + _ -> "{-# " ++ extractSpecPragName srcTxt ++ "_INLINE" + +ppr_sig (SpecSigE _ bndrs spec_e inl@(InlinePragma { inl_inline = spec })) = pragSrcBrackets srcTxt pragmaSrc $ pp_inl <+> hang (ppr bndrs) 2 (pprLExpr spec_e) where - srcTxt = case ghcPass @p of - GhcPs -> src - GhcRn -> inl_ghcrn_src src - GhcTc -> inl_ghcrn_src src + srcTxt = inlinePragmaSource inl -- SPECIALISE or SPECIALISE_INLINE pragmaSrc = case spec of NoUserInlinePrag -> "{-# " ++ extractSpecPragName srcTxt @@ -849,13 +843,8 @@ ppr_sig (SpecSigE _ bndrs spec_e inl@(InlinePragma { inl_src = src, inl_inline = ppr_sig (InlineSig _ var inl) = ppr_pfx <+> pprInline inl <+> pprPrefixOcc (unLoc var) <+> text "#-}" - where - srcTxt = case ghcPass @p of - GhcPs -> inl_src inl - GhcRn -> inl_ghcrn_src $ inl_src inl - GhcTc -> inl_ghcrn_src $ inl_src inl - - ppr_pfx = case srcTxt of + where + ppr_pfx = case inlinePragmaSource inl of SourceText src -> ftext src NoSourceText -> text "{-#" <+> inlinePragmaName (inl_inline inl) ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -157,13 +157,6 @@ type instance XDocD (GhcPass _) = NoExtField type instance XRoleAnnotD (GhcPass _) = NoExtField type instance XXHsDecl (GhcPass _) = DataConCantHappen -{- -type instance XInlinePragma GhcPs = SourceText -type instance XInlinePragma GhcRn = (SourceText, Arity) -type instance XInlinePragma GhcTc = (SourceText, Arity) -type instance XXInlinePragma (GhcPass _) = DataConCantHappen --} - -- | Partition a list of HsDecls into function/pattern bindings, signatures, -- type family declarations, type family instances, and documentation comments. -- ===================================== compiler/GHC/HsToCore/Binds.hs ===================================== @@ -457,19 +457,14 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs simpl_opts = initSimpleOpts dflags InlinePragma (InlinePragmaGhcTag _ arity) inl_spec _ _ = idInlinePragma gbl_id inlinable_unf = mkInlinableUnfolding simpl_opts StableUserSrc rhs - inline_pair - | arity > 0 - -- 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 - = ( 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) + 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) dictArity :: [Var] -> Arity -- Don't count coercion variables in arity @@ -1022,7 +1017,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 (unsetInlinePragmaArity id_inl) (unsetInlinePragmaArity spec_inl) + `setInlinePragInfo` specFunInlinePrag poly_id id_inl spec_inl `setUnfoldingInfo` spec_unf spec_id = mkLocalVar (idDetails poly_id) spec_name ManyTy spec_ty spec_info -- Specialised binding is toplevel, hence Many. @@ -1192,17 +1187,19 @@ getCastedVar (Var v) = Just (v, MRefl) getCastedVar (Cast (Var v) co) = Just (v, MCo co) getCastedVar _ = Nothing -specFunInlinePrag :: Id -> InlinePragma GhcPs - -> InlinePragma GhcPs -> InlinePragma GhcPs +specFunInlinePrag :: Id -> InlinePragma GhcTc + -> InlinePragma GhcTc -> InlinePragma GhcTc -- 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 + , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma `setInlinePragmaArity` arity | 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/Parser/PostProcess.hs ===================================== @@ -3045,7 +3045,7 @@ mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation -- The (Maybe Activation) is because the user can omit -- the activation spec (and usually does) mkInlinePragma src (inl, match_info) mb_act - = InlinePragma { inl_src = src -- See Note [Pragma source text] in "GHC.Types.SourceText" + = InlinePragma { inl_ext = src -- See Note [Pragma source text] in "GHC.Types.SourceText" , inl_inline = inl , inl_act = act , inl_rule = match_info } @@ -3060,7 +3060,7 @@ mkInlinePragma src (inl, match_info) mb_act mkOpaquePragma :: SourceText -> InlinePragma GhcPs mkOpaquePragma src - = InlinePragma { inl_src = src + = InlinePragma { inl_ext = src , inl_inline = Opaque -- By marking the OPAQUE pragma NeverActive we stop -- (constructor) specialisation on OPAQUE things. ===================================== 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) } + ; return (SpecSig noAnn new_v new_ty (inl `setInlinePragmaArity` 0), fvs) } -- TODO: setting arity to 0 is likely wrong where do_one (tys,fvs) ty = do { (new_ty, fvs_ty) <- rnHsSigType (SpecialiseSigCtx v) TypeLevel ty ===================================== compiler/GHC/ThToHs.hs ===================================== @@ -892,7 +892,7 @@ cvtPragmaD (InlineP nm inline rm phases) ; let src TH.NoInline = fsLit "{-# NOINLINE" src TH.Inline = fsLit "{-# INLINE" src TH.Inlinable = fsLit "{-# INLINABLE" - ; let ip = InlinePragma { inl_src = toSrcTxt inline + ; let ip = InlinePragma { inl_ext = toSrcTxt inline , inl_inline = cvtInline inline , inl_rule = cvtRuleMatch rm , inl_act = cvtPhases phases dflt } @@ -902,7 +902,7 @@ cvtPragmaD (InlineP nm inline rm phases) cvtPragmaD (OpaqueP nm) = do { nm' <- vNameN nm - ; let ip = InlinePragma { inl_src = srcTxt + ; let ip = InlinePragma { inl_ext = srcTxt , inl_inline = Opaque , inl_rule = Hs.FunLike , inl_act = NeverActive } @@ -1017,7 +1017,7 @@ cvtInlinePhases inline phases = SourceText $ fsLit "{-# SPECIALISE") where toSrcTxt a = SourceText $ src a - in InlinePragma { inl_src = srcText + in InlinePragma { inl_ext = srcText , inl_inline = inline' , inl_rule = Hs.FunLike , inl_act = cvtPhases phases dflt } ===================================== compiler/GHC/Types/Basic.hs ===================================== @@ -1338,12 +1338,12 @@ dfunInlinePragma = defaultInlinePragma { inl_act = AlwaysActive , inl_rule = ConLike } setInlinePragmaArity :: InlinePragma GhcPs -> Arity -> InlinePragma GhcTc -setInlinePragmaArity prag@(InlinePragma { inl_src = srcTxt }) arity = - prag { inl_src = InlinePragmaGhcTag srcTxt arity } +setInlinePragmaArity prag@(InlinePragma { inl_ext = srcTxt }) arity = + prag { inl_ext = InlinePragmaGhcTag srcTxt arity } inlinePragmaSource :: forall p. IsPass p => InlinePragma (GhcPass p) -> SourceText -inlinePragmaSource (InlinePragma { inl_src = src }) = srcTxt +inlinePragmaSource (InlinePragma { inl_ext = src }) = srcTxt where srcTxt = case ghcPass @p of GhcPs -> src ===================================== compiler/GHC/Types/Id/Info.hs ===================================== @@ -557,7 +557,7 @@ 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_src = src }) = pr `seq` info { inlinePragInfo = pr { inl_src = tag } } +setInlinePragInfo info pr@(InlinePragma { inl_ext = src }) = pr `seq` info { inlinePragInfo = pr { inl_ext = tag } } where tag :: InlinePragmaGhcTag tag = case ghcPass @p of ===================================== compiler/GHC/Types/InlinePragma.hs ===================================== @@ -59,6 +59,12 @@ module GHC.Types.InlinePragma -- ** Extensible record type for GhcRn & GhcTc , InlinePragmaGhcTag(..) + -- ** InlineSpec + -- *** Data-type + , InlineSpec(..) + -- *** Queries + , noUserInlineSpec + -- ** RuleMatchInfo -- *** Data-type , RuleMatchInfo(..) @@ -66,12 +72,6 @@ module GHC.Types.InlinePragma , isConLike , isFunLike - -- ** InlineSpec - -- *** Data-type - , InlineSpec(..) - -- *** Queries - , noUserInlineSpec - -- * Phase Activation -- ** Activation -- *** Data-type @@ -133,7 +133,7 @@ type instance XXInlinePragma (GhcPass _) = DataConCantHappen defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma :: InlinePragma GhcPs -defaultInlinePragma = InlinePragma { inl_src = SourceText $ fsLit "{-# INLINE" +defaultInlinePragma = InlinePragma { inl_ext = SourceText $ fsLit "{-# INLINE" , inl_act = AlwaysActive , inl_rule = FunLike , inl_inline = NoUserInlinePrag } @@ -161,26 +161,25 @@ isDefaultInlinePragma (InlinePragma { inl_act = activation setInlinePragmaArity :: forall p q. (IsPass p, XInlinePragma (GhcPass q) ~ InlinePragmaGhcTag) => InlinePragma (GhcPass p) -> Arity -> InlinePragma (GhcPass q) setInlinePragmaArity prag arity = - prag { inl_src = InlinePragmaGhcTag (inlinePragmaSource prag) arity } + prag { inl_ext = InlinePragmaGhcTag (inlinePragmaSource prag) arity } unsetInlinePragmaArity :: forall p. IsPass p => InlinePragma (GhcPass p) -> InlinePragma GhcPs unsetInlinePragmaArity prag = - prag { inl_src = inlinePragmaSource prag } + prag { inl_ext = inlinePragmaSource prag } inlinePragmaSource :: forall p. IsPass p => InlinePragma (GhcPass p) -> SourceText -inlinePragmaSource (InlinePragma { inl_src = src }) = srcTxt +inlinePragmaSource (InlinePragma { inl_ext = src }) = srcTxt where srcTxt = case ghcPass @p of GhcPs -> src GhcRn -> inl_ghcrn_src src GhcTc -> inl_ghcrn_src src --- TODO: Should we use coerce here? promoteInlinePragmaRn :: InlinePragma GhcRn -> InlinePragma GhcTc -promoteInlinePragmaRn prag@(InlinePragma { inl_src = src }) = prag { inl_src = src } +promoteInlinePragmaRn prag@(InlinePragma { inl_ext = src }) = prag { inl_ext = src } demoteInlinePragmaRn :: InlinePragma GhcTc -> InlinePragma GhcRn -demoteInlinePragmaRn prag@(InlinePragma { inl_src = src }) = prag { inl_src = src } +demoteInlinePragmaRn prag@(InlinePragma { inl_ext = src }) = prag { inl_ext = src } inlinePragmaSpec :: InlinePragma p -> InlineSpec inlinePragmaSpec = inl_inline @@ -192,7 +191,7 @@ 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_src = tag } +setInlinePragmaTag prag tag = prag { inl_ext = tag } setInlinePragmaActivation :: InlinePragma (GhcPass p) -> Activation -> InlinePragma (GhcPass p) setInlinePragmaActivation prag activation = prag { inl_act = activation } ===================================== compiler/GHC/Utils/Binary.hs ===================================== @@ -2087,14 +2087,6 @@ instance Binary Activation where _ -> do ab <- get bh return (ActiveAfter ab) -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 return ConLike - else return FunLike - instance Binary InlineSpec where put_ bh = putByte bh . \case NoUserInlinePrag -> 0 @@ -2110,3 +2102,11 @@ instance Binary InlineSpec where 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 return ConLike + else return FunLike ===================================== compiler/GHC/Utils/Outputable.hs ===================================== @@ -2049,10 +2049,6 @@ instance Outputable Activation where ppr (ActiveAfter n) = brackets (int n) ppr FinalActive = text "[final]" -instance Outputable RuleMatchInfo where - ppr ConLike = text "CONLIKE" - ppr FunLike = text "FUNLIKE" - instance Outputable InlineSpec where ppr Inline = text "INLINE" ppr NoInline = text "NOINLINE" @@ -2060,5 +2056,9 @@ instance Outputable InlineSpec where ppr Opaque = text "OPAQUE" ppr NoUserInlinePrag = empty +instance Outputable RuleMatchInfo where + ppr ConLike = text "CONLIKE" + ppr FunLike = text "FUNLIKE" + instance Outputable (InlinePragma (GhcPass p)) where ppr = pprInline ===================================== compiler/Language/Haskell/Syntax/Binds.hs ===================================== @@ -802,7 +802,7 @@ no harm. data InlinePragma pass -- Note [InlinePragma] = InlinePragma - { inl_src :: (XInlinePragma pass) -- See Note [Pragma source text] + { inl_ext :: (XInlinePragma pass) -- See Note [Pragma source text] , inl_inline :: InlineSpec -- See Note [inl_inline and inl_act] , inl_act :: Activation -- Says during which phases inlining is allowed -- See Note [inl_inline and inl_act] @@ -1021,7 +1021,7 @@ inlinePragmaRuleMatchInfo :: InlinePragma p -> RuleMatchInfo inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info setInlinePragmaTag :: InlinePragma p -> XInlinePragma q -> InlinePragma q -setInlinePragmaTag prag tag = prag { inl_src = tag } +setInlinePragmaTag prag tag = prag { inl_ext = tag } setInlinePragmaActivation :: InlinePragma p -> Activation -> InlinePragma p setInlinePragmaActivation prag activation = prag { inl_act = activation } ===================================== compiler/Language/Haskell/Syntax/Binds/InlinePragma.hs ===================================== @@ -25,6 +25,12 @@ module Language.Haskell.Syntax.Binds.InlinePragma , isNoInlinePragma , isOpaquePragma + -- ** InlineSpec + -- *** Data-type + , InlineSpec(..) + -- *** Queries + , noUserInlineSpec + -- ** RuleMatchInfo -- *** Data-type , RuleMatchInfo(..) @@ -32,12 +38,6 @@ module Language.Haskell.Syntax.Binds.InlinePragma , isConLike , isFunLike - -- ** InlineSpec - -- *** Data-type - , InlineSpec(..) - -- *** Queries - , noUserInlineSpec - -- * Phase Activation -- ** Activation -- *** Data-type @@ -68,7 +68,7 @@ import Prelude -- (Eq, Int, Show, ($), seq) data InlinePragma pass -- Note [InlinePragma] = InlinePragma - { inl_src :: (XInlinePragma pass) -- See Note [Pragma source text] + { inl_ext :: (XInlinePragma pass) -- See Note [Pragma source text] , inl_inline :: InlineSpec -- See Note [inl_inline and inl_act] , inl_act :: Activation -- Says during which phases inlining is allowed -- See Note [inl_inline and inl_act] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f0e98a453f10634acc0400bad3eca41b... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f0e98a453f10634acc0400bad3eca41b... You're receiving this email because of your account on gitlab.haskell.org.