Simon Peyton Jones pushed to branch wip/T27557 at Glasgow Haskell Compiler / GHC Commits: 4f2a21f7 by Andreas Klebinger at 2026-08-02T22:46:46-04:00 Apply oneShot Monad trick to STG LintM - - - - - 21e4b89d by Andreas Klebinger at 2026-08-02T22:46:46-04:00 stgLint: Use a single reader env for read only arguments. - - - - - d415f38a by Alan Zimmerman at 2026-08-02T22:47:27-04:00 EPA: Remove LocatedP from CType The next step of removing use of LocatedP by moving the AnnPragma for CType into its TTG extension point instead. - - - - - a7622111 by Simon Peyton Jones at 2026-08-03T13:50:08+01:00 Fix three bugs related to required type args and INLINE pragmas * `GHC.Core.Opt.Arity.mkEtaForAllMCo` got the visibility flags back to front, leading to a Lint error (#27557) * The arity in an InlineSaturation is the VisArity not the Arity; the two can differ when we have "required" type arguments. This made the INLINE pragma argument counting go wrong in `makeCorePair` (#27590). * When a simple binding has a type signature, we take special path in `tcPolyCheck`, leading to an outer `AbsBinds` that has no dictionaries, even when the binding is in fact overloaded. That confused the inline-arity computation in `makeCorePair` (#27589). The latter two are fixed using the new function `GHC.HsToCore.Binds.findSatArity`. That actually simplifies the API of `makeCorePair`, which is nice. The first bug is fixed by swapping the visiblity flags in `GHC.Core.Opt.Arity.mkEtaForAllMCo` Getting the INLINE behaviour right led to some perf changes: * Runtime /halved/ on T7954 due to better specialisation * Compile time increased by 6% in T21839c because a bit more inlining happened, as it always should have done. Geometric mean effect on our compile time benchmarks is +0.1%. Metric Decrease: T7954 Metric Increase: T21839c - - - - - 26 changed files: - + changelog.d/T27557 - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Stg/Lint.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Types/Arity.hs - compiler/GHC/Types/ForeignCall.hs - compiler/GHC/Types/InlinePragma.hs - compiler/GHC/Types/Var.hs - libraries/base/tests/perf/ElemFusionUnknownList_O1.stderr - + testsuite/tests/simplCore/should_compile/T27589.hs - + testsuite/tests/simplCore/should_compile/T27589.stderr - + testsuite/tests/simplCore/should_compile/T27590.hs - + testsuite/tests/simplCore/should_compile/T27590.stderr - testsuite/tests/simplCore/should_compile/all.T - + testsuite/tests/typecheck/should_compile/T27557.hs - testsuite/tests/typecheck/should_compile/all.T - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Types.hs Changes: ===================================== changelog.d/T27557 ===================================== @@ -0,0 +1,8 @@ +section: compiler +issues: #27577 #27589 #27590 +mrs: !16433 +synopsis: + Fix three bugs around INLINE pragmas +description: + One bug (#25777) gave a Lint error. The other two were lurking but un-reported; + they showed up when fixing the first ===================================== compiler/GHC/Core/Opt/Arity.hs ===================================== @@ -2370,11 +2370,15 @@ mkEtaForAllMCo (Bndr tcv vis) ty mco | otherwise -> mk_fco (mkRepReflCo ty) MCo co -> mk_fco co where - mk_fco co = MCo (mkForAllCo tcv vis coreTyLamForAllTyFlag MRefl co) + mk_fco co = MCo (mkForAllCo tcv coreTyLamForAllTyFlag vis MRefl co) -- coreTyLamForAllTyFlag: See Note [The EtaInfo mechanism], particularly -- the (EtaInfo Invariant). (sym co) wraps a lambda that always has -- a ForAllTyFlag of coreTyLamForAllTyFlag; see Note [Required foralls in Core] -- in GHC.Core.TyCo.Rep + -- + -- Orientation: remember, the output of mkEtaForAllCo goes into an `EI bs mco`, + -- and is SymCo'd in `etaInfoAbs`. Hence the orientation of the visibility + -- flags. A bit of a brain-strain (#27557). {- ************************************************************************ ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -1583,7 +1583,7 @@ type instance Anno (FunDep (GhcPass p)) = SrcSpanAnnA type instance Anno (FamilyResultSig (GhcPass p)) = EpAnnCO type instance Anno (FamilyDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (InjectivityAnn (GhcPass p)) = EpAnnCO -type instance Anno (CType (GhcPass p)) = SrcSpanAnnP +type instance Anno (CType (GhcPass p)) = SrcSpanAnnA type instance Anno (HsDerivingClause (GhcPass p)) = EpAnnCO type instance Anno (DerivClauseTys (GhcPass _)) = SrcSpanAnnA type instance Anno (StandaloneKindSig (GhcPass p)) = SrcSpanAnnA ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -1687,10 +1687,11 @@ isSingletonMatchGroup matches | otherwise = False -matchGroupArity :: MatchGroup (GhcPass id) body -> Arity +matchGroupVisArity :: MatchGroup (GhcPass id) body -> VisArity -- This is called before type checking, when mg_arg_tys is not set -matchGroupArity MG { mg_alts = L _ [] } = 1 -- See Note [Empty mg_alts] -matchGroupArity MG { mg_alts = L _ (alt1 : _) } = count isVisArgLPat (hsLMatchPats alt1) +-- Returns the "visible arity" of the MatchGroup i.e. including required type arguments. +matchGroupVisArity MG { mg_alts = L _ [] } = 1 -- See Note [Empty mg_alts] +matchGroupVisArity MG { mg_alts = L _ (alt1 : _) } = count isVisArgLPat (hsLMatchPats alt1) hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)] hsLMatchPats (L _ (Match { m_pats = L _ pats })) = pats ===================================== compiler/GHC/HsToCore/Binds.hs ===================================== @@ -69,7 +69,7 @@ import GHC.Types.InlinePragma import GHC.Types.Name import GHC.Types.Var.Set import GHC.Types.Var.Env -import GHC.Types.Var( EvVar, mkLocalVar ) +import GHC.Types.Var( EvVar, mkLocalVar, isRuntimePiTyBinder ) import GHC.Types.SrcLoc import GHC.Types.Basic import GHC.Types.Unique.Set( nonDetEltsUniqSet ) @@ -196,7 +196,7 @@ dsHsBind dflags (VarBind { var_id = var = do { core_expr <- dsLExpr expr -- Dictionary bindings are always VarBinds, -- so we only need do this here - ; let core_bind@(id,_) = makeCorePair dflags var False 0 core_expr + ; let core_bind@(id,_) = makeCorePair dflags var False core_expr force_var = if xopt LangExt.Strict dflags then [id] else [] @@ -211,11 +211,11 @@ dsHsBind dflags b@(FunBind { fun_id = L loc fun ; let body' = mkOptTickBox tick body rhs = core_wrap (mkLams args body') - core_binds@(id,_) = makeCorePair dflags fun False 0 rhs + core_binds@(id,_) = makeCorePair dflags fun False rhs force_var -- Bindings are strict when -XStrict is enabled | xopt LangExt.Strict dflags - , matchGroupArity matches == 0 -- no need to force lambdas + , matchGroupVisArity matches == 0 -- no need to force lambdas = [id] | isBangedHsBind b = [id] @@ -303,7 +303,7 @@ dsAbsBinds dflags tyvars dicts exports ; let global_id' = addIdSpecialisations global_id rules main_bind = makeCorePair dflags global_id' (isDefaultMethod prags) - (dictArity dicts) rhs + rhs ; return (force_vars', fromOL spec_binds ++ [main_bind]) } } @@ -386,7 +386,7 @@ dsAbsBinds dflags tyvars dicts exports mk_aux_bind (lcl_id, rhs) = let lcl_w_inline = lookupVarEnv inline_env lcl_id `orElse` lcl_id in - makeCorePair dflags lcl_w_inline False 0 rhs + makeCorePair dflags lcl_w_inline False rhs inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with -- the inline pragma from the source @@ -437,9 +437,9 @@ dsAbsBinds dflags tyvars dicts exports -- the unfolding in the interface file is made in `GHC.Iface.Tidy.addExternal` -- using this information. ------------------------ -makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr +makeCorePair :: DynFlags -> Id -> Bool -> CoreExpr -> (Id, CoreExpr) -makeCorePair dflags gbl_id is_default_method dict_arity rhs +makeCorePair dflags gbl_id is_default_method rhs | is_default_method -- Default methods are *always* inlined -- See Note [INLINE and default methods] in GHC.Tc.TyCl.Instance = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding' simpl_opts rhs, rhs) @@ -456,22 +456,43 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs inline_prag = idInlinePragma gbl_id inlinable_unf = mkInlinableUnfolding simpl_opts StableUserSrc rhs inline_pair - | AppliedToAtLeast arity <- inlinePragmaSaturation inline_prag + | AppliedToAtLeast vis_arity <- inlinePragmaSaturation 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 + 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) + , let runtime_arity = findSatArity vis_arity (idType gbl_id) + -- NB: runtime_arity: the arity passed to mkInlineUnfoldingWithArity + -- must take account of dictionaries and required type args + = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity simpl_opts StableUserSrc + runtime_arity rhs + , etaExpand runtime_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 -dictArity dicts = count isId dicts +findSatArity :: VisArity -> Type -> Arity +-- Given the VisArity, find the value Arity of the function. +-- This is the number of runtime-value arguments the function must be applied +-- to before the INLINE pragma fires and inlines the function +-- We must: +-- add one for each invisible dictionary arg; and +-- subtract one for each required type argment +findSatArity vis_arity ty + = go vis_arity pi_bndrs + where + (pi_bndrs, _) = splitPiTys ty + + go vis_arity (bndr : bndrs) + | isInvisiblePiTyBinder bndr = add_bndr bndr (go vis_arity bndrs) + | vis_arity == 0 = 0 + | otherwise = add_bndr bndr (go (vis_arity-1) bndrs) + go vis_arity [] + | vis_arity == 0 = 0 + | otherwise = pprPanic "findSatArity" (ppr vis_arity $$ ppr ty) + + add_bndr :: PiTyBinder -> Arity -> Arity + add_bndr bndr ar | isRuntimePiTyBinder bndr = ar+1 + | otherwise = ar {- Note [Desugaring AbsBinds] ===================================== compiler/GHC/HsToCore/Match.hs ===================================== @@ -737,21 +737,21 @@ Call @match@ with all of this information! -- There are three possible cases for matchWrapper's scrutinees argument: -- -- 1. Nothing Used for FunBind, HsLam, HsLamcase, where there is no explicit scrutinee --- The MatchGroup may have matchGroupArity of 0 or more. Examples: --- f p1 q1 = ... -- matchGroupArity 2 +-- The MatchGroup may have matchGroupVisArity of 0 or more. Examples: +-- f p1 q1 = ... -- matchGroupVisArity 2 -- f p2 q2 = ... -- -- \cases | g1 -> ... -- matchGroupArity 0 -- | g2 -> ... -- -- 2. Just [e] Used for HsCase, RecordUpd; exactly one scrutinee --- The MatchGroup has matchGroupArity of exactly 1. Example: --- case e of p1 -> e1 -- matchGroupArity 1 +-- The MatchGroup has matchGroupVisArity of exactly 1. Example: +-- case e of p1 -> e1 -- matchGroupVisArity 1 -- p2 -> e2 -- -- 3. Just es Used for HsCmdLamCase; zero or more scrutinees -- The MatchGroup has matchGroupArity of (length es). Example: --- \cases p1 q1 -> returnA -< ... -- matchGroupArity 2 +-- \cases p1 q1 -> returnA -< ... -- matchGroupVisArity 2 -- p2 q2 -> ... matchWrapper ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -288,7 +288,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches -- We don't want to generate code for blacklisted positions -- We don't want redundant ticks on simple pattern bindings -- We don't want to tick non-exported bindings in TickExportedFunctions - let simple = matchGroupArity matches == 0 + let simple = matchGroupVisArity matches == 0 -- A binding is a "simple pattern binding" if it is a -- funbind with zero patterns toplev = null decl_path ===================================== compiler/GHC/Parser.y ===================================== @@ -1707,15 +1707,17 @@ datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs | type { sL1 $1 (Nothing, mkHsOuterImplicit, $1) } -capi_ctype :: { Maybe (LocatedP (CType GhcPs)) } +capi_ctype :: { Maybe (LocatedA (CType GhcPs)) } capi_ctype : '{-# CTYPE' STRING STRING '#-}' - {% fmap Just $ amsr (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $3) (Just (Header (getSTRINGs $2) (getSTRING $2))) - (getSTRING $3))) - (AnnPragma (glR $1) (epTok $4) noAnn (glR $2) (glR $3) noAnn noAnn) } + {% fmap Just $ amsA' (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $3) + (AnnPragma (glR $1) (epTok $4) noAnn (glR $2) (glR $3) noAnn noAnn) + (Just (Header (getSTRINGs $2) (getSTRING $2))) + (getSTRING $3)))} | '{-# CTYPE' STRING '#-}' - {% fmap Just $ amsr (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $2) Nothing (getSTRING $2))) - (AnnPragma (glR $1) (epTok $3) noAnn noAnn (glR $2) noAnn noAnn) } + {% fmap Just $ amsA' (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $2) + (AnnPragma (glR $1) (epTok $3) noAnn noAnn (glR $2) noAnn noAnn) + Nothing (getSTRING $2)))} | { Nothing } ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -229,7 +229,7 @@ mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layout annsIn mkTyData :: SrcSpan -> Bool -> NewOrData - -> Maybe (LocatedP (CType GhcPs)) + -> Maybe (LocatedA (CType GhcPs)) -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Maybe (LHsKind GhcPs) -> [LConDecl GhcPs] @@ -251,7 +251,7 @@ mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr)) tcdDataDefn = defn, tcdModifiers = [] })) } -mkDataDefn :: Maybe (LocatedP (CType GhcPs)) +mkDataDefn :: Maybe (LocatedA (CType GhcPs)) -> Maybe (LHsContext GhcPs) -> Maybe (LHsKind GhcPs) -> DataDefnCons (LConDecl GhcPs) @@ -326,7 +326,7 @@ mkTyFamInstEqn loc bndrs lhs rhs annEq mkDataFamInst :: SrcSpan -> NewOrData - -> Maybe (LocatedP (CType GhcPs)) + -> Maybe (LocatedA (CType GhcPs)) -> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs , LHsType GhcPs) -> Maybe (LHsKind GhcPs) ===================================== compiler/GHC/Stg/Lint.hs ===================================== @@ -92,6 +92,7 @@ be ill-typed in Core. But it must still be well-kinded! -} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PatternSynonyms #-} module GHC.Stg.Lint ( lintStgTopBindings ) where @@ -123,6 +124,7 @@ import GHC.Unit.Module ( Module ) import GHC.Data.Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) import Control.Monad +import GHC.Exts ( oneShot ) import GHC.Core.Multiplicity (scaledThing) import GHC.Settings (Platform) import GHC.Core.TyCon (primRepCompatible, primRepsCompatible) @@ -432,17 +434,40 @@ The Lint monad ************************************************************************ -} -newtype LintM a = LintM - { unLintM :: Module - -> LintFlags - -> DiagOpts -- Diagnostic options - -> StgPprOpts -- Pretty-printing options +data LintReaderEnv = LintReaderEnv + { le_mod :: !Module + , le_flags :: !LintFlags + , le_diag_opts :: !DiagOpts -- Diagnostic options + , le_ppr_opts :: !StgPprOpts -- Pretty-printing options + } + +newtype LintM a = LintM' + { unLintM :: LintReaderEnv -> [LintLocInfo] -- Locations -> IdSet -- Local vars in scope -> Bag SDoc -- Error messages so far -> (a, Bag SDoc) -- Result and error messages (if any) } - deriving (Functor) +instance Functor LintM where + fmap f (LintM m) = + LintM $ \env loc scope errs -> + case m env loc scope errs of + (a, errs') -> (f a, errs') + +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +{-# COMPLETE LintM #-} +pattern LintM :: (LintReaderEnv + -> [LintLocInfo] + -> IdSet + -> Bag SDoc + -> (a, Bag SDoc)) + -> LintM a +pattern LintM m <- LintM' m + where + LintM m = LintM' $ oneShot (\env -> oneShot + (\loc -> oneShot + (\scope -> oneShot + (\errs -> m env loc scope errs)))) data LintFlags = LintFlags { lf_unarised :: !Bool , lf_platform :: !Platform @@ -473,14 +498,16 @@ pp_binders bs initL :: Platform -> DiagOpts -> Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc initL platform diag_opts this_mod unarised opts locals (LintM m) = do - let (_, errs) = m this_mod (LintFlags unarised platform) diag_opts opts [] locals emptyBag + let !flags = LintFlags unarised platform + !env = LintReaderEnv this_mod flags diag_opts opts + (_, errs) = m env [] locals emptyBag if isEmptyBag errs then Nothing else Just (vcat (punctuate blankLine (bagToList errs))) instance Applicative LintM where - pure a = LintM $ \_mod _lf _df _opts _loc _scope errs -> (a, errs) + pure a = LintM $ \_env _loc _scope errs -> (a, errs) (<*>) = ap (*>) = thenL_ @@ -489,14 +516,14 @@ instance Monad LintM where (>>) = (*>) thenL :: LintM a -> (a -> LintM b) -> LintM b -thenL m k = LintM $ \mod lf diag_opts opts loc scope errs - -> case unLintM m mod lf diag_opts opts loc scope errs of - (r, errs') -> unLintM (k r) mod lf diag_opts opts loc scope errs' +thenL m k = LintM $ \env loc scope errs + -> case unLintM m env loc scope errs of + (r, errs') -> unLintM (k r) env loc scope errs' thenL_ :: LintM a -> LintM b -> LintM b -thenL_ m k = LintM $ \mod lf diag_opts opts loc scope errs - -> case unLintM m mod lf diag_opts opts loc scope errs of - (_, errs') -> unLintM k mod lf diag_opts opts loc scope errs' +thenL_ m k = LintM $ \env loc scope errs + -> case unLintM m env loc scope errs of + (_, errs') -> unLintM k env loc scope errs' checkL :: Bool -> SDoc -> LintM () checkL True _ = return () @@ -525,7 +552,8 @@ checkPostUnariseId id id_ty = idType id addErrL :: SDoc -> LintM () -addErrL msg = LintM $ \_mod _lf df _opts loc _scope errs -> ((), addErr df errs msg loc) +addErrL msg = LintM $ \LintReaderEnv{le_diag_opts = df} loc _scope errs + -> ((), addErr df errs msg loc) addErr :: DiagOpts -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc addErr diag_opts errs_so_far msg locs @@ -537,23 +565,23 @@ addErr diag_opts errs_so_far msg locs mk_msg [] = msg addLoc :: LintLocInfo -> LintM a -> LintM a -addLoc extra_loc m = LintM $ \mod lf diag_opts opts loc scope errs - -> unLintM m mod lf diag_opts opts (extra_loc:loc) scope errs +addLoc extra_loc m = LintM $ \env loc scope errs + -> unLintM m env (extra_loc:loc) scope errs addInScopeVars :: [Id] -> LintM a -> LintM a -addInScopeVars ids m = LintM $ \mod lf diag_opts opts loc scope errs +addInScopeVars ids m = LintM $ \env loc scope errs -> let new_set = mkVarSet ids - in unLintM m mod lf diag_opts opts loc (scope `unionVarSet` new_set) errs + in unLintM m env loc (scope `unionVarSet` new_set) errs getLintFlags :: LintM LintFlags -getLintFlags = LintM $ \_mod lf _df _opts _loc _scope errs -> (lf, errs) +getLintFlags = LintM $ \LintReaderEnv{le_flags = lf} _loc _scope errs -> (lf, errs) getStgPprOpts :: LintM StgPprOpts -getStgPprOpts = LintM $ \_mod _lf _df opts _loc _scope errs -> (opts, errs) +getStgPprOpts = LintM $ \LintReaderEnv{le_ppr_opts = opts} _loc _scope errs -> (opts, errs) checkInScope :: Id -> LintM () -checkInScope id = LintM $ \mod _lf diag_opts _opts loc scope errs +checkInScope id = LintM $ \LintReaderEnv{le_mod = mod, le_diag_opts = diag_opts} loc scope errs -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then ((), addErr diag_opts errs (hsep [ppr id, dcolon, ppr (idType id), text "is out of scope"]) loc) ===================================== compiler/GHC/Tc/Gen/Bind.hs ===================================== @@ -808,7 +808,7 @@ checkMonomorphismRestriction mbis lbinds restricted (VarBind { var_ext = x }) = dataConCantHappen x restricted b@(PatSynBind {}) = pprPanic "isRestrictedGroup/unrestricted" (ppr b) - restricted_match mg = matchGroupArity mg == 0 + restricted_match mg = matchGroupVisArity mg == 0 -- No args => like a pattern binding -- Some args => a function binding ===================================== compiler/GHC/Tc/Gen/Sig.hs ===================================== @@ -599,26 +599,26 @@ mkPragEnv sigs binds Nothing -> sig -- See Note [Pattern synonym inline arity] -- ar_env maps a local to the arity of its definition - ar_env :: NameEnv Arity - ar_env = foldr lhsBindArity emptyNameEnv binds + ar_env :: NameEnv VisArity + ar_env = foldr lhsBindVisArity emptyNameEnv binds -addInlinePragArity :: Arity -> LSig GhcRn -> LSig GhcRn +addInlinePragArity :: VisArity -> LSig GhcRn -> LSig GhcRn addInlinePragArity ar (L l (InlineSig x nm inl)) = L l (InlineSig x nm (add_inl_arity ar inl)) addInlinePragArity ar (L l (SpecSig x nm ty inl)) = L l (SpecSig x nm ty (add_inl_arity ar inl)) addInlinePragArity ar (L l (SpecSigE n x e inl)) = L l (SpecSigE n x e (add_inl_arity ar inl)) addInlinePragArity _ sig = sig -add_inl_arity :: Arity -> InlinePragma GhcRn -> InlinePragma GhcRn +add_inl_arity :: VisArity -> 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 `setInlinePragmaSaturation` AppliedToAtLeast ar | otherwise = prag -lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity -lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env - = extendNameEnv env (unLoc id) (matchGroupArity ms) -lhsBindArity _ env = env -- PatBind/VarBind +lhsBindVisArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity +lhsBindVisArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env + = extendNameEnv env (unLoc id) (matchGroupVisArity ms) +lhsBindVisArity _ env = env -- PatBind/VarBind ----------------- ===================================== compiler/GHC/Types/Arity.hs ===================================== @@ -84,7 +84,14 @@ like Haskell, there is more than one way to count those arguments. 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. + arguments, i.e. arguments that occur visibly in the source code. For example: + f1 :: forall a. a -> a + f1 x = x + f2 :: forall a -> a -> a + f2 t x = x + Both have Arity 1 because there is one /value/ argument. + But f1 has VisArity 1 while f2 has VisArity 2, becuase f2 has a required + type argument. 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 (==) ===================================== compiler/GHC/Types/ForeignCall.hs ===================================== @@ -109,6 +109,7 @@ import Data.Data (Data) import Data.Functor ((<&>)) import Control.DeepSeq (NFData(..)) +import GHC.Parser.Annotation (AnnPragma, noAnn) {- ************************************************************************ @@ -213,11 +214,11 @@ instance Outputable CCallSpec where defaultCType :: String -> CType (GhcPass p) defaultCType = - CType (CTypeGhc NoSourceText NoSourceText) Nothing . packHText + CType (CTypeGhc NoSourceText NoSourceText noAnn) Nothing . packHText -mkCType :: SourceText -> SourceText -> Maybe (Header (GhcPass p)) -> HText -> CType (GhcPass p) -mkCType x y m = - CType (CTypeGhc x y) m +mkCType :: SourceText -> SourceText -> AnnPragma -> Maybe (Header (GhcPass p)) -> HText -> CType (GhcPass p) +mkCType x y ann m = + CType (CTypeGhc x y ann) m typeCheckCType :: CType GhcRn -> CType GhcTc typeCheckCType (CType x y z) = CType x (typeCheckHeader <$> y) z @@ -302,6 +303,7 @@ data StaticTargetGhc = StaticTargetGhc data CTypeGhc = CTypeGhc { cTypeSourceText :: SourceText , cTypeOtherText :: SourceText + , cTypeAnn :: AnnPragma } deriving (Data, Eq) @@ -349,6 +351,7 @@ instance Binary CTypeGhc where return $ CTypeGhc { cTypeSourceText = str1 , cTypeOtherText = str2 + , cTypeAnn = noAnn } instance NFData StaticTargetGhc where ===================================== compiler/GHC/Types/InlinePragma.hs ===================================== @@ -104,7 +104,7 @@ import GHC.Prelude import GHC.Data.FastString import GHC.Hs.Extension -import GHC.Types.Arity (Arity) +import GHC.Types.Arity (VisArity) import GHC.Types.SourceText (SourceText(..)) import GHC.Utils.Binary import GHC.Utils.Outputable @@ -125,12 +125,13 @@ infixl 1 `setInlinePragmaActivation`, -- | The arity /at which to/ inline a function. -- This may differ from the function's syntactic arity. data InlineSaturation - = AppliedToAtLeast !Arity + = AppliedToAtLeast !VisArity -- ^ Inline only when applied to @n@ explicit - -- (non-type, non-dictionary) arguments. + -- (required type or value) arguments. -- -- That is, 'AppliedToAtLeast' describes the number of -- *source-code* arguments the thing must be applied to. + | AnySaturation -- ^ There does not exist an explicit number of arguments -- that the inlining process should be applied to. ===================================== compiler/GHC/Types/Var.hs ===================================== @@ -82,7 +82,7 @@ module GHC.Types.Var ( -- * PiTyBinder PiTyBinder(..), PiTyVarBinder, isInvisiblePiTyBinder, isInvisibleAnonPiTyBinder, - isVisiblePiTyBinder, + isVisiblePiTyBinder, isRuntimePiTyBinder, isTyBinder, isNamedPiTyBinder, isAnonPiTyBinder, namedPiTyBinder_maybe, anonPiTyBinderType_maybe, piTyBinderType, @@ -757,7 +757,12 @@ instance NamedThing tv => NamedThing (VarBndr tv flag) where -- not. See Note [PiTyBinders] data PiTyBinder = Named ForAllTyBinder -- A type-lambda binder, with a ForAllTyFlag - | Anon (Scaled Type) FunTyFlag -- A term-lambda binder. Type here can be CoercionTy. + -- Erased (not passed at runtime) if the binder is + -- a type variable; not erased if coercion variable + + | Anon (Scaled Type) FunTyFlag -- A term-lambda binder, passing a runtime value + -- The argument can be a constraint (incl dictionary) + -- or an ordinary value -- The arrow is described by the FunTyFlag deriving Data @@ -792,6 +797,12 @@ namedPiTyBinder_maybe :: PiTyBinder -> Maybe TyCoVar namedPiTyBinder_maybe (Named tv) = Just $ binderVar tv namedPiTyBinder_maybe _ = Nothing +isRuntimePiTyBinder :: PiTyBinder -> Bool +isRuntimePiTyBinder (Anon {}) = True -- Always passed at runtime +isRuntimePiTyBinder (Named (Bndr tcv _)) = isCoVar tcv + -- isCoVar: see Note [Why ForAllTy can quantify over a coercion variable] + -- and Note [Unused coercion variable in ForAllTy], in GHC.Core.TyCo.Rep + -- | Does this binder bind a variable that is /not/ erased? Returns -- 'True' for anonymous binders. isAnonPiTyBinder :: PiTyBinder -> Bool @@ -817,7 +828,7 @@ piTyBinderType (Named (Bndr tv _)) = varType tv piTyBinderType (Anon ty _) = scaledThing ty {- Note [PiTyBinders] -~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~ But a type like forall a. Maybe a -> forall b. (a,b) -> b @@ -830,14 +841,18 @@ argument to a Pi-type. GHC Core currently supports two different Pi-types: * Anon ty1 fun_flag: a non-dependent function type, - written with ->, e.g. ty1 -> ty2 - represented as FunTy ty1 ty2. These are - lifted to Coercions with the corresponding FunCo. + written with ->, e.g. ty1 -> ty2 + represented as FunTy ty1 ty2. + + See wrinkle (PIT1) + + These are lifted to Coercions with the corresponding FunCo. + + * Named (Var tcv forall_flag): a dependent polytype, + written with forall, e.g. forall (a:*). ty + represented as ForAllTy (Bndr a v) ty - * Named (Var tv forall_flag) - A dependent compile-time-only polytype, - written with forall, e.g. forall (a:*). ty - represented as ForAllTy (Bndr a v) ty + See wrinkle (PIT2) Both forms of Pi-types classify terms/types that take an argument. In other words, if `x` is either a function or a polytype, `x arg` makes sense @@ -845,12 +860,16 @@ words, if `x` is either a function or a polytype, `x arg` makes sense Wrinkles -* The Anon constructor of PiTyBinder contains a FunTyFlag. Since +(PIT1) The Anon constructor of PiTyBinder contains a FunTyFlag. Since the PiTyBinder really only describes the /argument/ it should perhaps only have a TypeOrConstraint rather than a full FunTyFlag. But it's very convenient to have the full FunTyFlag, say in mkPiTys, so that's what we do. +(PIT2) The `tcv` in `Named (Var tcv forall_flag) is usually a type variable + but can exceptionally be a coercion variable: see + Note [Why ForAllTy can quantify over a coercion variable]. + If it's a type variable it will be erased; if coercion variable it will not. Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== libraries/base/tests/perf/ElemFusionUnknownList_O1.stderr ===================================== @@ -43,17 +43,17 @@ fusionElemFilter jump go1 eta fusionNotElemConcatMap - = \ x x1 -> + = \ x eta -> joinrec { go1 ds = case ds of { [] -> True; : y ys -> - case y of { I# x2 -> - case x of { I# x3 -> - case ==# x3 (+# x2 1#) of { + case y of { I# x1 -> + case x of { I# x2 -> + case ==# x2 (+# x1 1#) of { __DEFAULT -> - case ==# x3 (+# x2 2#) of { + case ==# x2 (+# x1 2#) of { __DEFAULT -> jump go1 ys; 1# -> False }; @@ -62,20 +62,20 @@ fusionNotElemConcatMap } } }; } in - jump go1 x1 + jump go1 eta fusionElemConcatMap - = \ x x1 -> + = \ x eta -> joinrec { go1 ds = case ds of { [] -> False; : y ys -> - case y of { I# x2 -> - case x of { I# x3 -> - case ==# x3 (+# x2 1#) of { + case y of { I# x1 -> + case x of { I# x2 -> + case ==# x2 (+# x1 1#) of { __DEFAULT -> - case ==# x3 (+# x2 2#) of { + case ==# x2 (+# x1 2#) of { __DEFAULT -> jump go1 ys; 1# -> True }; @@ -84,7 +84,7 @@ fusionElemConcatMap } } }; } in - jump go1 x1 + jump go1 eta fusionNotElemMap = \ x eta -> ===================================== testsuite/tests/simplCore/should_compile/T27589.hs ===================================== @@ -0,0 +1,9 @@ +module T28589 where + +wombat :: Num a => a -> a +{-# INLINE wombat #-} +wombat x = x+x*x + +g :: Num a => [a] -> [a] +g ys = map wombat ys + -- wombat should not inline here ===================================== testsuite/tests/simplCore/should_compile/T27589.stderr ===================================== @@ -0,0 +1,3 @@ +wombat [InlPrag=INLINE (sat-args=1)] :: forall a. Num a => a -> a +wombat + map @a @a (wombat @a $dNum) ys ===================================== testsuite/tests/simplCore/should_compile/T27590.hs ===================================== @@ -0,0 +1,10 @@ +{-# LANGUAGE RequiredTypeArguments #-} + +module Foo where + +wombat :: forall a -> a -> Maybe a +{-# INLINE wombat #-} +wombat t x = Just x + +g y = wombat Int (y+y) + -- wombat /should/ inline here ===================================== testsuite/tests/simplCore/should_compile/T27590.stderr ===================================== @@ -0,0 +1,2 @@ +wombat [InlPrag=INLINE (sat-args=2)] :: forall a -> a -> Maybe a +wombat ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -609,3 +609,5 @@ test('T4081', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-a test('T27261', [extra_files(['T27261_aux.hs'])], multimod_compile, ['T27261', '-v0 -O']) test('T27296', [], makefile_test, ['T27296']) test('T27296b', [], makefile_test, ['T27296b']) +test('T27589', [grep_errmsg(r'wombat')], compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques']) +test('T27590', [grep_errmsg(r'wombat')], compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques']) ===================================== testsuite/tests/typecheck/should_compile/T27557.hs ===================================== @@ -0,0 +1,9 @@ +{-# LANGUAGE RequiredTypeArguments #-} + +module RequiredTypeArgumentsMkSymCo where + +import Data.Kind (Type) + +f :: forall a . forall (b :: Type) -> a -> a +f t = id +{-# INLINE f #-} ===================================== testsuite/tests/typecheck/should_compile/all.T ===================================== @@ -968,4 +968,4 @@ test('T24464', normal, compile, ['']) test('ExpansionQLIm', normal, compile, ['']) test('T23135', normal, compile, ['']) test('LazyFieldAnnotations', normal, compile, ['']) - +test('T27557', normal, compile, ['']) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -4401,13 +4401,14 @@ instance ExactPrint t => ExactPrint (HsModifierOf t GhcPs) where -- --------------------------------------------------------------------- -instance Typeable p => ExactPrint (LocatedP (CType (GhcPass p))) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn +instance Typeable p => ExactPrint (CType (GhcPass p)) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a - exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (CType ext mh ct)) = do + exact (CType ext mh ct) = do let stp = cTypeSourceText ext stct = cTypeOtherText ext + AnnPragma o c s l1 l2 t m = cTypeAnn ext o' <- markAnnOpen'' o stp "{-# CTYPE" l1' <- case mh of Nothing -> return l1 @@ -4415,7 +4416,7 @@ instance Typeable p => ExactPrint (LocatedP (CType (GhcPass p))) where printStringAtAA l1 (toSourceTextWithSuffix srcH "" "") l2' <- printStringAtAA l2 (toSourceTextWithSuffix stct (unpackHText ct) "") c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' s l1' l2' t m) cs) (CType ext mh ct)) + return (CType (ext { cTypeAnn = AnnPragma o' c' s l1' l2' t m }) mh ct) -- --------------------------------------------------------------------- ===================================== utils/haddock/haddock-api/src/Haddock/Types.hs ===================================== @@ -837,7 +837,7 @@ type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA type instance Anno (HsSigType DocNameI) = SrcSpanAnnA type instance Anno (BooleanFormula DocNameI) = SrcSpanAnnBF type instance Anno (OverlapMode DocNameI) = SrcSpanAnnA -type instance Anno (CType DocNameI) = EpAnn AnnPragma +type instance Anno (CType DocNameI) = SrcSpanAnnA type instance Anno (Header DocNameI) = EpAnn AnnPragma type instance Anno (HsModifierOf (LocatedA (HsType DocNameI)) DocNameI) = SrcSpanAnnA type instance Anno (HsContextDetails DocNameI a) = SrcSpanAnnA View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/40a8449cc16f332bb1165d0a7fdd494... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/40a8449cc16f332bb1165d0a7fdd494... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help