[Git][ghc/ghc][wip/fix-26670] A very untidy, partial reorganization [COMPILES]

recursion-ninja pushed to branch wip/fix-26670 at Glasgow Haskell Compiler / GHC Commits: b57f032c by Recursion Ninja at 2025-12-17T09:20:10-05:00 A very untidy, partial reorganization [COMPILES] - - - - - 15 changed files: - compiler/GHC/Core/Opt/WorkWrap.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Tc/Deriv/Generics.hs - compiler/GHC/Tc/Gen/Arrow.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Utils/Instantiate.hs - + compiler/GHC/Types/Arity.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/Id/Info.hs - compiler/GHC/Types/InlinePragma.hs - compiler/Language/Haskell/Syntax/Binds.hs - compiler/ghc.cabal.in Changes: ===================================== 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 = XInlinePragmaGhcRn srcTxt arity + work_prag = InlinePragma { inl_src = 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 = XInlinePragmaGhcRn srcTxt arity + = InlinePragma { inl_src = InlinePragmaGhcTag srcTxt arity , inl_inline = fn_inl -- See Note [Worker/wrapper for INLINABLE functions] ===================================== compiler/GHC/HsToCore.hs ===================================== @@ -77,6 +77,7 @@ import GHC.Utils.Logger import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Id.Make ( mkRepPolyIdConcreteTyVars ) +import GHC.Types.InlinePragma ( alwaysInlinePragma ) import GHC.Types.ForeignStubs import GHC.Types.Avail import GHC.Types.Var.Set ===================================== compiler/GHC/HsToCore/Binds.hs ===================================== @@ -49,7 +49,6 @@ import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) import GHC.Core.InstEnv ( CanonicalEvidence(..) ) import GHC.Core.Make import GHC.Core.Utils -import GHC.Core.Opt.Arity ( etaExpand ) import GHC.Core.Unfold.Make import GHC.Core.FVs import GHC.Core.Predicate ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -1097,7 +1097,7 @@ rep_wc_ty_sig mk_sig loc sig_ty nm = rep_ty_sig mk_sig loc (hswc_body sig_ty) nm rep_inline :: LocatedN Name - -> InlinePragma -- Never defaultInlinePragma + -> InlinePragma GhcRn -- Never defaultInlinePragma -> SrcSpan -> MetaM [(SrcSpan, Core (M TH.Dec))] rep_inline nm ispec loc @@ -1116,7 +1116,7 @@ rep_inline nm ispec loc ; return [(loc, pragma)] } -rep_inline_phases :: InlinePragma -> MetaM (Maybe (Core TH.Inline), Core TH.Phases) +rep_inline_phases :: InlinePragma GhcRn -> MetaM (Maybe (Core TH.Inline), Core TH.Phases) rep_inline_phases (InlinePragma { inl_act = act, inl_inline = inl }) = do { phases <- repPhases act ; inl <- if noUserInlineSpec inl @@ -1126,7 +1126,7 @@ rep_inline_phases (InlinePragma { inl_act = act, inl_inline = inl }) else Just <$> repInline inl ; return (inl, phases) } -rep_specialise :: LocatedN Name -> LHsSigType GhcRn -> InlinePragma +rep_specialise :: LocatedN Name -> LHsSigType GhcRn -> InlinePragma GhcRn -> SrcSpan -> MetaM [(SrcSpan, Core (M TH.Dec))] rep_specialise nm ty ispec loc @@ -1138,7 +1138,7 @@ rep_specialise nm ty ispec loc ; return [(loc, pragma)] } -rep_specialiseE :: RuleBndrs GhcRn -> LHsExpr GhcRn -> InlinePragma +rep_specialiseE :: RuleBndrs GhcRn -> LHsExpr GhcRn -> InlinePragma GhcRn -> MetaM (Core (M TH.Dec)) rep_specialiseE bndrs e ispec -- New form SPECIALISE pragmas ===================================== compiler/GHC/Rename/Bind.hs ===================================== @@ -1111,15 +1111,15 @@ renameSig ctxt sig@(SpecSig _ v tys inl) ; return ( new_ty:tys, fvs_ty `plusFV` fvs) } renameSig _ctxt (SpecSigE _ bndrs spec_e inl) - = do { (fn_rdr <- checkSpecESigShape spec_e - ; (fn_name <- lookupOccRn WL_TermVariable fn_rdr -- Checks that the head isn't forall-bound + = do { fn_rdr <- checkSpecESigShape spec_e + ; 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), fvs) } } + ; return (SpecSigE fn_name bndrs' spec_e' ( inl `setInlinePragmaArity` 0), fvs) } } -- TODO: setting arity to 0 is likely wrong renameSig ctxt sig@(InlineSig _ v s) = do { new_v <- lookupSigOccRn ctxt sig v - ; return (InlineSig noAnn new_v s, emptyFVs) } + ; return (InlineSig noAnn new_v ( s `setInlinePragmaArity` 0 ), emptyFVs) } -- TODO: setting arity to 0 is likely wrong renameSig ctxt (FixSig _ fsig) = do { new_fsig <- rnSrcFixityDecl ctxt fsig ===================================== compiler/GHC/Tc/Deriv/Generics.hs ===================================== @@ -42,6 +42,7 @@ import GHC.Unit.Module ( moduleName, moduleUnit import GHC.Iface.Env ( newGlobalBinder ) +import GHC.Types.InlinePragma ( alwaysInlinePragma ) import GHC.Types.Name hiding ( varName ) import GHC.Types.Name.Reader import GHC.Types.SrcLoc ===================================== compiler/GHC/Tc/Gen/Arrow.hs ===================================== @@ -34,6 +34,7 @@ import GHC.Tc.Types.Origin import GHC.Tc.Types.Evidence import GHC.Core.Multiplicity import GHC.Core.Coercion +import GHC.Types.Arity ( Arity ) import GHC.Types.Id( mkLocalId ) import GHC.Tc.Utils.Instantiate import GHC.Builtin.Types ===================================== compiler/GHC/Tc/TyCl/Instance.hs ===================================== @@ -73,6 +73,8 @@ 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 import GHC.Types.Name @@ -1430,11 +1432,12 @@ 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 + `setInlinePragma` (dfunInlinePragma `setInlinePragmaArity` arity) -- NOTE: Check if this arity calculation is correct -- NB: mkDFunUnfolding takes care of unary classes where - dict_args = map Type inst_tys ++ - [mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids] + arity = length var_apps + dict_args = map Type inst_tys ++ var_apps + var_apps = [mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids] (dfun_tvs, dfun_theta, clas, inst_tys) = tcSplitDFunTy (idType dfun_id) ev_ids = mkTemplateLocalsNum 1 dfun_theta @@ -2266,7 +2269,8 @@ mkDefMethBind :: SrcSpan -> DFunId -> Class -> Id -> Name mkDefMethBind loc dfun_id clas sel_id dm_name dm_spec = do { logger <- getLogger ; dm_id <- tcLookupId dm_name - ; let inline_prag = idInlinePragma dm_id + ; let inline_prag :: InlinePragma GhcRn + inline_prag = demoteInlinePragmaRn $ idInlinePragma dm_id inline_prags | isAnyInlinePragma inline_prag = [noLocA (InlineSig noAnn fn inline_prag)] | otherwise @@ -2668,9 +2672,11 @@ 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) $ - 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) } + 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) } tcSpecInst _ _ = panic "tcSpecInst" ===================================== compiler/GHC/Tc/Utils/Instantiate.hs ===================================== @@ -74,7 +74,8 @@ import GHC.Tc.Zonk.Monad ( ZonkM ) import GHC.Rename.Utils( mkRnSyntaxExpr ) import GHC.Types.Id.Make( mkDictFunId ) -import GHC.Types.Basic ( TypeOrKind(..), VisArity ) +import GHC.Types.Arity ( Arity, VisArity ) +import GHC.Types.Basic ( TypeOrKind(..) ) import GHC.Types.SourceText import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Var.Env ===================================== compiler/GHC/Types/Arity.hs ===================================== @@ -0,0 +1,129 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1997-1998 + +\section[BasicTypes]{Miscellaneous types} + +This module defines a miscellaneously collection of very simple +types that + +\begin{itemize} +\item have no other obvious home +\item don't depend on any other complicated types +\item are used in more than one "part" of the compiler +\end{itemize} +-} + +module GHC.Types.Arity + ( Arity + , VisArity + , RepArity + , JoinArity + , FullArgCount + ) where + +import GHC.Prelude + +{- +************************************************************************ +* * +\subsection[Arity]{Arity} +* * +************************************************************************ +-} + +-- | The number of value arguments that can be applied to a value before it does +-- "real work". So: +-- fib 100 has arity 0 +-- \x -> fib x has arity 1 +-- 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 + +-- | Representation Arity +-- +-- The number of represented arguments that can be applied to a value before it does +-- "real work". So: +-- fib 100 has representation arity 0 +-- \x -> fib x has representation arity 1 +-- \(# x, y #) -> fib (x + y) has representation arity 2 +type RepArity = Int + +-- | The number of arguments that a join point takes. Unlike the arity of a +-- function, this is a purely syntactic property and is fixed when the join +-- point is created (or converted from a value). Both type and value arguments +-- 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 + +{- Note [Visibility and arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Arity is the number of arguments that a function expects. In a curried language +like Haskell, there is more than one way to count those arguments. + +* `Arity` is the classic notion of arity, concerned with evalution, so it counts + the number of /value/ arguments that need to be supplied before evaluation can + take place, as described in notes + Note [Definition of arity] in GHC.Core.Opt.Arity + Note [Arity and function types] in GHC.Types.Id.Info + + Examples: + Int has arity == 0 + Int -> Int has arity <= 1 + Int -> Bool -> Int has arity <= 2 + We write (<=) rather than (==) as sometimes evaluation can occur before all + value arguments are supplied, depending on the actual function definition. + + This evaluation-focused notion of arity ignores type arguments, so: + forall a. a has arity == 0 + forall a. a -> a has arity <= 1 + forall a b. a -> b -> a has arity <= 2 + This is true regardless of ForAllTyFlag, so the arity is also unaffected by + (forall {a}. ty) or (forall a -> ty). + + Class dictionaries count towards the arity, as they are passed at runtime + forall a. (Num a) => a has arity <= 1 + forall a. (Num a) => a -> a has arity <= 2 + forall a b. (Num a, Ord b) => a -> b -> a has arity <= 4 + +* `VisArity` is the syntactic notion of arity. It is the number of /visible/ + arguments, i.e. arguments that occur visibly in the source code. + + In a function call `f x y z`, we can confidently say that f's vis-arity >= 3, + simply because we see three arguments [x,y,z]. We write (>=) rather than (==) + as this could be a partial application. + + At definition sites, we can acquire an underapproximation of vis-arity by + counting the patterns on the LHS, e.g. `f a b = rhs` has vis-arity >= 2. + The actual vis-arity can be higher if there is a lambda on the RHS, + e.g. `f a b = \c -> rhs`. + + If we look at the types, we can observe the following + * function arrows (a -> b) add to the vis-arity + * visible foralls (forall a -> b) add to the vis-arity + * constraint arrows (a => b) do not affect the vis-arity + * invisible foralls (forall a. b) do not affect the vis-arity + + This means that ForAllTyFlag matters for VisArity (in contrast to Arity), + while the type/value distinction is unimportant (again in contrast to Arity). + + Examples: + Int -- vis-arity == 0 (no args) + Int -> Int -- vis-arity == 1 (1 funarg) + forall a. a -> a -- vis-arity == 1 (1 funarg) + forall a. Num a => a -> a -- vis-arity == 1 (1 funarg) + forall a -> Num a => a -- vis-arity == 1 (1 req tyarg, 0 funargs) + forall a -> a -> a -- vis-arity == 2 (1 req tyarg, 1 funarg) + Int -> forall a -> Int -- vis-arity == 2 (1 funarg, 1 req tyarg) + + Wrinkle: with TypeApplications and TypeAbstractions, it is possible to visibly + bind and pass invisible arguments, e.g. `f @a x = ...` or `f @Int 42`. Those + @-prefixed arguments are ignored for the purposes of vis-arity. +-} ===================================== compiler/GHC/Types/Basic.hs ===================================== @@ -133,7 +133,7 @@ module GHC.Types.Basic ( ImportLevel(..), convImportLevel, convImportLevelSpec, allImportLevels, --- XInlinePragmaGhc(..) +-- InlinePragmaGhcTag(..) ) where import GHC.Prelude @@ -143,6 +143,7 @@ import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Binary +import GHC.Types.Arity import GHC.Types.SourceText import qualified GHC.LanguageExtensions as LangExt import {-# SOURCE #-} Language.Haskell.Syntax.Type (PromotionFlag(..), isPromoted) @@ -187,105 +188,6 @@ instance NFData LeftOrRight where rnf CLeft = () rnf CRight = () - - -{- -************************************************************************ -* * -\subsection[Arity]{Arity} -* * -************************************************************************ --} - --- | Syntactic (visibility) arity, i.e. the number of visible arguments. --- See Note [Visibility and arity] -type VisArity = Int - --- | Representation Arity --- --- The number of represented arguments that can be applied to a value before it does --- "real work". So: --- fib 100 has representation arity 0 --- \x -> fib x has representation arity 1 --- \(# x, y #) -> fib (x + y) has representation arity 2 -type RepArity = Int - --- | The number of arguments that a join point takes. Unlike the arity of a --- function, this is a purely syntactic property and is fixed when the join --- point is created (or converted from a value). Both type and value arguments --- 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 - -{- Note [Visibility and arity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Arity is the number of arguments that a function expects. In a curried language -like Haskell, there is more than one way to count those arguments. - -* `Arity` is the classic notion of arity, concerned with evalution, so it counts - the number of /value/ arguments that need to be supplied before evaluation can - take place, as described in notes - Note [Definition of arity] in GHC.Core.Opt.Arity - Note [Arity and function types] in GHC.Types.Id.Info - - Examples: - Int has arity == 0 - Int -> Int has arity <= 1 - Int -> Bool -> Int has arity <= 2 - We write (<=) rather than (==) as sometimes evaluation can occur before all - value arguments are supplied, depending on the actual function definition. - - This evaluation-focused notion of arity ignores type arguments, so: - forall a. a has arity == 0 - forall a. a -> a has arity <= 1 - forall a b. a -> b -> a has arity <= 2 - This is true regardless of ForAllTyFlag, so the arity is also unaffected by - (forall {a}. ty) or (forall a -> ty). - - Class dictionaries count towards the arity, as they are passed at runtime - forall a. (Num a) => a has arity <= 1 - forall a. (Num a) => a -> a has arity <= 2 - forall a b. (Num a, Ord b) => a -> b -> a has arity <= 4 - -* `VisArity` is the syntactic notion of arity. It is the number of /visible/ - arguments, i.e. arguments that occur visibly in the source code. - - In a function call `f x y z`, we can confidently say that f's vis-arity >= 3, - simply because we see three arguments [x,y,z]. We write (>=) rather than (==) - as this could be a partial application. - - At definition sites, we can acquire an underapproximation of vis-arity by - counting the patterns on the LHS, e.g. `f a b = rhs` has vis-arity >= 2. - The actual vis-arity can be higher if there is a lambda on the RHS, - e.g. `f a b = \c -> rhs`. - - If we look at the types, we can observe the following - * function arrows (a -> b) add to the vis-arity - * visible foralls (forall a -> b) add to the vis-arity - * constraint arrows (a => b) do not affect the vis-arity - * invisible foralls (forall a. b) do not affect the vis-arity - - This means that ForAllTyFlag matters for VisArity (in contrast to Arity), - while the type/value distinction is unimportant (again in contrast to Arity). - - Examples: - Int -- vis-arity == 0 (no args) - Int -> Int -- vis-arity == 1 (1 funarg) - forall a. a -> a -- vis-arity == 1 (1 funarg) - forall a. Num a => a -> a -- vis-arity == 1 (1 funarg) - forall a -> Num a => a -- vis-arity == 1 (1 req tyarg, 0 funargs) - forall a -> a -> a -- vis-arity == 2 (1 req tyarg, 1 funarg) - Int -> forall a -> Int -- vis-arity == 2 (1 funarg, 1 req tyarg) - - Wrinkle: with TypeApplications and TypeAbstractions, it is possible to visibly - bind and pass invisible arguments, e.g. `f @a x = ...` or `f @Int 42`. Those - @-prefixed arguments are ignored for the purposes of vis-arity. --} - {- ************************************************************************ * * @@ -1439,18 +1341,18 @@ failed Succeeded = False failed Failed = True {- -data XInlinePragmaGhc = XInlinePragmaGhcRn +data InlinePragmaGhcTag = InlinePragmaGhcTag { inl_ghcrn_src :: {-# UNPACK#-} !SourceText , inl_ghcrn_arity :: {-# UNPACK#-} !Arity } deriving (Eq, Data) -instance NFData XInlinePragmaGhc where - rnf (XInlinePragmaGhcRn s a) = rnf s `seq` rnf a `seq` () +instance NFData InlinePragmaGhcTag where + rnf (InlinePragmaGhcTag s a) = rnf s `seq` rnf a `seq` () type instance XInlinePragma GhcPs = SourceText -type instance XInlinePragma GhcRn = XInlinePragmaGhc -type instance XInlinePragma GhcTc = XInlinePragmaGhc +type instance XInlinePragma GhcRn = InlinePragmaGhcTag +type instance XInlinePragma GhcTc = InlinePragmaGhcTag type instance XXInlinePragma (GhcPass _) = DataConCantHappen defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma @@ -1474,7 +1376,7 @@ dfunInlinePragma = defaultInlinePragma { inl_act = AlwaysActive setInlinePragmaArity :: InlinePragma GhcPs -> Arity -> InlinePragma GhcTc setInlinePragmaArity prag@(InlinePragma { inl_src = srcTxt }) arity = - prag { inl_src = XInlinePragmaGhcRn srcTxt arity } + prag { inl_src = InlinePragmaGhcTag srcTxt arity } {- inlinePragmaSource :: forall p. IsPass p => InlinePragma (GhcPass p) -> SourceText @@ -2072,15 +1974,15 @@ instance Binary InlineSpec where instance Outputable (InlinePragma (GhcPass p)) where ppr = pprInline -instance Binary XInlinePragmaGhc where - put_ bh (XInlinePragmaGhcRn s a) = do +instance Binary InlinePragmaGhcTag where + put_ bh (InlinePragmaGhcTag s a) = do put_ bh s put_ bh a get bh = do s <- get bh a <- get bh - return (XInlinePragmaGhcRn s a) + return (InlinePragmaGhcTag s a) instance Binary (InlinePragma GhcPs) where put_ bh (InlinePragma s a b c) = do ===================================== compiler/GHC/Types/Id/Info.hs ===================================== @@ -564,11 +564,11 @@ setRuleInfo info sp = sp `seq` info { ruleInfo = sp } 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 } } where - tag :: XInlinePragmaGhc + tag :: InlinePragmaGhcTag tag = case ghcPass @p of - GhcPs -> XInlinePragmaGhcRn (src :: SourceText) 0 - GhcRn -> (src :: XInlinePragmaGhc) - GhcTc -> (src :: XInlinePragmaGhc) + GhcPs -> InlinePragmaGhcTag (src :: SourceText) 0 + GhcRn -> (src :: InlinePragmaGhcTag) + GhcTc -> (src :: InlinePragmaGhcTag) setOccInfo :: IdInfo -> OccInfo -> IdInfo setOccInfo info oc = oc `seq` info { occInfo = oc } ===================================== compiler/GHC/Types/InlinePragma.hs ===================================== @@ -52,10 +52,13 @@ module GHC.Types.InlinePragma ( setInlinePragmaArity, unsetInlinePragmaArity, pprInline, pprInlineDebug, + + -- ** Pass conversions + demoteInlinePragmaRn, promoteInlinePragmaRn, -- ** Extensible record type for GhcRn & GhcTc - XInlinePragmaGhc(..) + InlinePragmaGhcTag(..) ) where import GHC.Prelude @@ -64,25 +67,26 @@ import GHC.Data.FastString import GHC.Hs.Extension import GHC.Utils.Outputable import GHC.Utils.Binary +import GHC.Types.Arity (Arity) import GHC.Types.SourceText -import Control.DeepSeq ( NFData(..) ) +import Control.DeepSeq (NFData(..)) import Data.Data import Language.Haskell.Syntax.Binds import Language.Haskell.Syntax.Extension -data XInlinePragmaGhc = XInlinePragmaGhcRn +data InlinePragmaGhcTag = InlinePragmaGhcTag { inl_ghcrn_src :: {-# UNPACK#-} !SourceText , inl_ghcrn_arity :: {-# UNPACK#-} !Arity } deriving (Eq, Data) -instance NFData XInlinePragmaGhc where - rnf (XInlinePragmaGhcRn s a) = rnf s `seq` rnf a `seq` () +instance NFData InlinePragmaGhcTag where + rnf (InlinePragmaGhcTag s a) = rnf s `seq` rnf a `seq` () type instance XInlinePragma GhcPs = SourceText -type instance XInlinePragma GhcRn = XInlinePragmaGhc -type instance XInlinePragma GhcTc = XInlinePragmaGhc +type instance XInlinePragma GhcRn = InlinePragmaGhcTag +type instance XInlinePragma GhcTc = InlinePragmaGhcTag type instance XXInlinePragma (GhcPass _) = DataConCantHappen defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma @@ -105,10 +109,10 @@ alwaysInlineConLikePragma = alwaysInlinePragma { inl_rule = ConLike } dfunInlinePragma = defaultInlinePragma { inl_act = AlwaysActive , inl_rule = ConLike } -setInlinePragmaArity :: forall p q. (IsPass p, XInlinePragma (GhcPass q) ~ XInlinePragmaGhc) +setInlinePragmaArity :: forall p q. (IsPass p, XInlinePragma (GhcPass q) ~ InlinePragmaGhcTag) => InlinePragma (GhcPass p) -> Arity -> InlinePragma (GhcPass q) setInlinePragmaArity prag arity = - prag { inl_src = XInlinePragmaGhcRn (inlinePragmaSource prag) arity } + prag { inl_src = InlinePragmaGhcTag (inlinePragmaSource prag) arity } unsetInlinePragmaArity :: forall p. IsPass p => InlinePragma (GhcPass p) -> InlinePragma GhcPs unsetInlinePragmaArity prag = @@ -126,6 +130,9 @@ inlinePragmaSource (InlinePragma { inl_src = src }) = srcTxt promoteInlinePragmaRn :: InlinePragma GhcRn -> InlinePragma GhcTc promoteInlinePragmaRn prag@(InlinePragma { inl_src = src }) = prag { inl_src = src } +demoteInlinePragmaRn :: InlinePragma GhcTc -> InlinePragma GhcRn +demoteInlinePragmaRn prag@(InlinePragma { inl_src = src }) = prag { inl_src = src } + -- | Outputs string for pragma name for any of INLINE/INLINABLE/NOINLINE. This -- differs from the Outputable instance for the InlineSpec type where the pragma -- name string as well as the accompanying SourceText (if any) is printed. @@ -238,54 +245,32 @@ instance Binary InlineSpec where instance Outputable (InlinePragma (GhcPass p)) where ppr = pprInline -instance Binary XInlinePragmaGhc where - put_ bh (XInlinePragmaGhcRn s a) = do - put_ bh s - put_ bh a - - get bh = do - s <- get bh - a <- get bh - return (XInlinePragmaGhcRn s a) - -instance Binary (InlinePragma GhcPs) where - put_ bh (InlinePragma s a b c) = do - put_ bh s - put_ bh a - put_ bh b - put_ bh c - - get bh = do - s <- get bh - a <- get bh - b <- get bh - c <- get bh - return (InlinePragma s a b c) - -instance Binary (InlinePragma GhcRn) where - put_ bh (InlinePragma s a b c) = do +instance Binary InlinePragmaGhcTag where + put_ bh (InlinePragmaGhcTag s a) = do put_ bh s put_ bh a - put_ bh b - put_ bh c get bh = do s <- get bh a <- get bh - b <- get bh - c <- get bh - return (InlinePragma s a b c) + return (InlinePragmaGhcTag s a) -instance Binary (InlinePragma GhcTc) where +instance forall p. IsPass p => Binary (InlinePragma (GhcPass p)) where put_ bh (InlinePragma s a b c) = do - put_ bh s put_ bh a put_ bh b put_ bh c + case ghcPass @p of + GhcPs -> put_ bh s + GhcRn -> put_ bh s + GhcTc -> put_ bh s get bh = do - s <- get bh a <- get bh b <- get bh c <- get bh + s <- case ghcPass @p of + GhcPs -> get bh + GhcRn -> get bh + GhcTc -> get bh return (InlinePragma s a b c) ===================================== compiler/Language/Haskell/Syntax/Binds.hs ===================================== @@ -556,13 +556,6 @@ data HsPatSynDir id | ImplicitBidirectional | ExplicitBidirectional (MatchGroup id (LHsExpr id)) --- | The number of value arguments that can be applied to a value before it does --- "real work". So: --- fib 100 has arity 0 --- \x -> fib x has arity 1 --- See also Note [Definition of arity] in "GHC.Core.Opt.Arity" -type Arity = Int - {- ************************************************************************ * * ===================================== compiler/ghc.cabal.in ===================================== @@ -902,6 +902,7 @@ Library GHC.Tc.Zonk.Type GHC.ThToHs GHC.Types.Annotations + GHC.Types.Arity GHC.Types.Avail GHC.Types.Basic GHC.Types.CompleteMatch View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b57f032c0c205e4b6eed413dc84aa083... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b57f032c0c205e4b6eed413dc84aa083... You're receiving this email because of your account on gitlab.haskell.org.