[Git][ghc/ghc][wip/T18566] Add CALLER_CC pragma
Ben Gamari
gitlab at gitlab.haskell.org
Fri Aug 14 01:31:41 UTC 2020
Ben Gamari pushed to branch wip/T18566 at Glasgow Haskell Compiler / GHC
Commits:
e6c0d6b0 by Ben Gamari at 2020-08-14T01:31:12+00:00
Add CALLER_CC pragma
- - - - -
21 changed files:
- compiler/GHC/Core/CallerCc.hs → compiler/GHC/Core/AddCallerCcs.hs
- compiler/GHC/Core/Lint.hs
- − compiler/GHC/Core/Opt/AddCallerCcs.hs
- compiler/GHC/Core/Opt/Monad.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Core/Opt/WorkWrap.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Extension.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Types/Id.hs
- compiler/GHC/Types/Id/Info.hs
- compiler/ghc.cabal.in
Changes:
=====================================
compiler/GHC/Core/CallerCc.hs → compiler/GHC/Core/AddCallerCcs.hs
=====================================
@@ -6,28 +6,28 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE TupleSections #-}
-module GHC.Core.CallerCc (addCallerCcs) where
-
-import Data.Maybe
-import Data.Data
-import qualified Data.Generics as SYB
-import GHC.Generics
+module GHC.Core.AddCallerCcs (addCallerCcs) where
import Control.Monad.Trans.State.Strict
-import qualified Data.ByteString.Lazy as BSL
-import qualified Data.Binary as B
-import Data.List (intercalate)
-import GHC
import GHC.Prelude
-import GHC.Serialized
import GHC.Utils.Outputable
+import GHC.Driver.Session
+import GHC.Driver.Types
import GHC.Types.CostCentre
import GHC.Types.CostCentre.State
+import GHC.Types.Name (nameSrcSpan)
+import GHC.Types.SrcLoc
+import GHC.Types.Var
+import GHC.Unit.Types
+import GHC.Data.FastString
+import GHC.Types.Id.Info
import GHC.Core
+import GHC.Core.Opt.Monad
-addCallerCcs :: DynFlags -> ModGuts -> ModGuts
-addCallerCcs dflags guts = do
+addCallerCcs :: ModGuts -> CoreM ModGuts
+addCallerCcs guts = do
+ dflags <- getDynFlags
let env :: Env
env = Env
{ thisModule = mg_module guts
@@ -35,9 +35,7 @@ addCallerCcs dflags guts = do
, dflags = dflags
, revParents = []
}
- in guts { mg_binds = doCoreProgram env (mg_binds guts)
- , mg_anns = anns'
- }
+ return $ guts { mg_binds = doCoreProgram env (mg_binds guts) }
doCoreProgram :: Env -> CoreProgram -> CoreProgram
doCoreProgram env binds = flip evalState newCostCentreState $ do
@@ -51,12 +49,12 @@ doBind env (Rec bs) = Rec <$> mapM doPair bs
doExpr :: Env -> CoreExpr -> M CoreExpr
doExpr env e@(Var v)
- | needsCallSiteCostCentre env v = do
+ | needsCallSiteCostCentre v = do
let nameDoc :: SDoc
nameDoc = fsep (punctuate dot (map ppr (parents env))) <> parens (text "calling " <> ppr v)
ccName :: CcName
- ccName = mkFastString $ showSDoc (dflags env) nameDoc
+ ccName = mkFastString $ showSDocOneLine (initSDocContext (dflags env) defaultUserStyle) nameDoc
ccIdx <- getCCIndex' ccName
let span = case revParents env of
top:_ -> nameSrcSpan $ varName top
@@ -66,7 +64,7 @@ doExpr env e@(Var v)
tick = ProfNote cc True True
pure $ Tick tick e
| otherwise = pure e
-doExpr env e@(Lit _) = pure e
+doExpr _env e@(Lit _) = pure e
doExpr env (f `App` x) = App <$> doExpr env f <*> doExpr env x
doExpr env (Lam b x) = Lam b <$> doExpr env x
doExpr env (Let b rhs) = Let <$> doBind env b <*> doExpr env rhs
@@ -76,8 +74,8 @@ doExpr env (Case scrut b ty alts) =
doAlt (con, bs, rhs) = (con, bs,) <$> doExpr env rhs
doExpr env (Cast expr co) = Cast <$> doExpr env expr <*> pure co
doExpr env (Tick t e) = Tick t <$> doExpr env e
-doExpr env e@(Type _) = pure e
-doExpr env e@(Coercion _) = pure e
+doExpr _env e@(Type _) = pure e
+doExpr _env e@(Coercion _) = pure e
type M = State CostCentreState
@@ -97,8 +95,8 @@ addParent i env = env { revParents = i : revParents env }
parents :: Env -> [Id]
parents env = reverse (revParents env)
-needsCallSiteCostCentre :: Env -> Id -> Bool
-needsCallSiteCostCentre env i =
+needsCallSiteCostCentre :: Id -> Bool
+needsCallSiteCostCentre i =
case callerCcInfo $ idInfo i of
WantsCallerCc -> True
NoCallerCc -> False
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -349,6 +349,7 @@ coreDumpFlag CoreTidy = Just Opt_D_dump_simpl
coreDumpFlag CorePrep = Just Opt_D_dump_prep
coreDumpFlag CoreOccurAnal = Just Opt_D_dump_occur_anal
+coreDumpFlag CoreAddCallerCcs = Nothing
coreDumpFlag CoreDoPrintCore = Nothing
coreDumpFlag (CoreDoRuleCheck {}) = Nothing
coreDumpFlag CoreDoNothing = Nothing
=====================================
compiler/GHC/Core/Opt/AddCallerCcs.hs deleted
=====================================
@@ -1,104 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE TupleSections #-}
-
-module GHC.Opt.Core.AddCallerCcs (addCallerCcs) where
-
-import Data.Maybe
-import Data.Data
-import qualified Data.Generics as SYB
-import GHC.Generics
-
-import Control.Monad.Trans.State.Strict
-import qualified Data.ByteString.Lazy as BSL
-import qualified Data.Binary as B
-import Data.List (intercalate)
-
-import GHC
-import GHC.Prelude
-import GHC.Serialized
-import GHC.Utils.Outputable
-import GHC.Types.CostCentre
-import GHC.Types.CostCentre.State
-import GHC.Core
-
-addCallerCcs :: DynFlags -> ModGuts -> ModGuts
-addCallerCcs dflags guts = do
- let env :: Env
- env = Env
- { thisModule = mg_module guts
- , ccState = newCostCentreState
- , dflags = dflags
- , revParents = []
- }
- in guts { mg_binds = doCoreProgram env (mg_binds guts)
- , mg_anns = anns'
- }
-
-doCoreProgram :: Env -> CoreProgram -> CoreProgram
-doCoreProgram env binds = flip evalState newCostCentreState $ do
- mapM (doBind env) binds
-
-doBind :: Env -> CoreBind -> M CoreBind
-doBind env (NonRec b rhs) = NonRec b <$> doExpr (addParent b env) rhs
-doBind env (Rec bs) = Rec <$> mapM doPair bs
- where
- doPair (b,rhs) = (b,) <$> doExpr (addParent b env) rhs
-
-doExpr :: Env -> CoreExpr -> M CoreExpr
-doExpr env e@(Var v)
- | needsCallSiteCostCentre env v = do
- let nameDoc :: SDoc
- nameDoc = fsep (punctuate dot (map ppr (parents env))) <> parens (text "calling " <> ppr v)
-
- ccName :: CcName
- ccName = mkFastString $ showSDoc (dflags env) nameDoc
- ccIdx <- getCCIndex' ccName
- let span = case revParents env of
- top:_ -> nameSrcSpan $ varName top
- _ -> noSrcSpan
- cc = NormalCC (ExprCC ccIdx) ccName (thisModule env) span
- tick :: Tickish Id
- tick = ProfNote cc True True
- pure $ Tick tick e
- | otherwise = pure e
-doExpr env e@(Lit _) = pure e
-doExpr env (f `App` x) = App <$> doExpr env f <*> doExpr env x
-doExpr env (Lam b x) = Lam b <$> doExpr env x
-doExpr env (Let b rhs) = Let <$> doBind env b <*> doExpr env rhs
-doExpr env (Case scrut b ty alts) =
- Case <$> doExpr env scrut <*> pure b <*> pure ty <*> mapM doAlt alts
- where
- doAlt (con, bs, rhs) = (con, bs,) <$> doExpr env rhs
-doExpr env (Cast expr co) = Cast <$> doExpr env expr <*> pure co
-doExpr env (Tick t e) = Tick t <$> doExpr env e
-doExpr env e@(Type _) = pure e
-doExpr env e@(Coercion _) = pure e
-
-type M = State CostCentreState
-
-getCCIndex' :: FastString -> M CostCentreIndex
-getCCIndex' name = state (getCCIndex name)
-
-data Env = Env
- { thisModule :: !Module
- , dflags :: !DynFlags
- , ccState :: !CostCentreState
- , revParents :: [Id]
- }
-
-addParent :: Id -> Env -> Env
-addParent i env = env { revParents = i : revParents env }
-
-parents :: Env -> [Id]
-parents env = reverse (revParents env)
-
-needsCallSiteCostCentre :: Env -> Id -> Bool
-needsCallSiteCostCentre env i =
- case callerCcInfo $ idInfo i of
- WantsCallerCc -> True
- NoCallerCc -> False
=====================================
compiler/GHC/Core/Opt/Monad.hs
=====================================
@@ -121,6 +121,7 @@ data CoreToDo -- These are diff core-to-core passes,
| CoreTidy
| CorePrep
+ | CoreAddCallerCcs
| CoreOccurAnal
instance Outputable CoreToDo where
=====================================
compiler/GHC/Core/Opt/Pipeline.hs
=====================================
@@ -50,6 +50,7 @@ import GHC.Core.Opt.CprAnal ( cprAnalProgram )
import GHC.Core.Opt.CallArity ( callArityAnalProgram )
import GHC.Core.Opt.Exitify ( exitifyProgram )
import GHC.Core.Opt.WorkWrap ( wwTopBinds )
+import GHC.Core.AddCallerCcs ( addCallerCcs )
import GHC.Types.SrcLoc
import GHC.Utils.Misc
import GHC.Unit.Module.Env
@@ -140,6 +141,7 @@ getCoreToDo dflags
eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags
ww_on = gopt Opt_WorkerWrapper dflags
static_ptrs = xopt LangExt.StaticPointers dflags
+ profiling = gopt Opt_ProfCallerCcs dflags
maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
@@ -347,7 +349,9 @@ getCoreToDo dflags
-- can become /exponentially/ more expensive. See #11731, #12996.
runWhen (strictness || late_dmd_anal) CoreDoDemand,
- maybe_rule_check FinalPhase
+ maybe_rule_check FinalPhase,
+
+ runWhen profiling CoreAddCallerCcs
]
-- Remove 'CoreDoNothing' and flatten 'CoreDoPasses' for clarity.
@@ -464,6 +468,8 @@ doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-}
doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-}
specConstrProgram
+doCorePass CoreAddCallerCcs = {-# SCC "AddCallerCcs" #-}
+ addCallerCcs
doCorePass CoreDoPrintCore = observe printCore
doCorePass (CoreDoRuleCheck phase pat) = ruleCheckPass phase pat
=====================================
compiler/GHC/Core/Opt/WorkWrap.hs
=====================================
@@ -622,6 +622,8 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs
`setIdDemandInfo` worker_demand
+ `setIdCallerCcInfo` callerCcInfo fn_info
+
`setIdArity` work_arity
-- Set the arity so that the Core Lint check that the
-- arity is consistent with the demand type goes
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -450,10 +450,15 @@ toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other)
toIfaceIdInfo :: IdInfo -> IfaceIdInfo
toIfaceIdInfo id_info
= catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, cpr_hsinfo,
- inline_hsinfo, unfold_hsinfo, levity_hsinfo]
+ inline_hsinfo, unfold_hsinfo, levity_hsinfo, caller_cc_hsinfo]
-- NB: strictness and arity must appear in the list before unfolding
-- See GHC.IfaceToCore.tcUnfolding
where
+ ------------ CALLER_CC --------------
+ caller_cc_hsinfo = case callerCcInfo id_info of
+ WantsCallerCc -> Just HsWantsCallerCc
+ _ -> Nothing
+
------------ Arity --------------
arity_info = arityInfo id_info
arity_hsinfo | arity_info == 0 = Nothing
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -214,6 +214,7 @@ data GeneralFlag
-- profiling opts
| Opt_AutoSccsOnIndividualCafs
| Opt_ProfCountEntries
+ | Opt_ProfCallerCcs
-- misc opts
| Opt_Pp
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -3535,6 +3535,7 @@ fFlagsDeps = [
flagSpec "print-typechecker-elaboration" Opt_PrintTypecheckerElaboration,
flagSpec "prof-cafs" Opt_AutoSccsOnIndividualCafs,
flagSpec "prof-count-entries" Opt_ProfCountEntries,
+ flagSpec "prof-caller-ccs" Opt_ProfCallerCcs,
flagSpec "regs-graph" Opt_RegsGraph,
flagSpec "regs-iterative" Opt_RegsIterative,
depFlagSpec' "rewrite-rules" Opt_EnableRewriteRules
@@ -3852,6 +3853,7 @@ defaultFlags settings
Opt_OmitYields,
Opt_PrintBindContents,
Opt_ProfCountEntries,
+ Opt_ProfCallerCcs,
Opt_RPath,
Opt_SharedImplib,
Opt_SimplPreInlining,
=====================================
compiler/GHC/Hs/Binds.hs
=====================================
@@ -1016,6 +1016,12 @@ data Sig pass
SourceText -- Note [Pragma source text] in GHC.Types.Basic
(XRec pass (IdP pass)) -- Function name
(Maybe (XRec pass StringLiteral))
+
+ -- | A @CALLER_CC@ pragma for a declaration.
+ | CallerCcSig (XCallerCcSig pass)
+ SourceText
+ (XRec pass (IdP pass))
+
-- | A complete match pragma
--
-- > {-# COMPLETE C, D [:: T] #-}
@@ -1027,6 +1033,7 @@ data Sig pass
SourceText
(XRec pass [XRec pass (IdP pass)])
(Maybe (XRec pass (IdP pass)))
+
| XSig !(XXSig pass)
type instance XTypeSig (GhcPass p) = NoExtField
@@ -1039,6 +1046,7 @@ type instance XSpecSig (GhcPass p) = NoExtField
type instance XSpecInstSig (GhcPass p) = NoExtField
type instance XMinimalSig (GhcPass p) = NoExtField
type instance XSCCFunSig (GhcPass p) = NoExtField
+type instance XCallerCcSig (GhcPass p) = NoExtField
type instance XCompleteMatchSig (GhcPass p) = NoExtField
type instance XXSig (GhcPass p) = NoExtCon
@@ -1108,8 +1116,9 @@ isPragLSig :: forall p. UnXRec p => LSig p -> Bool
isPragLSig (unXRec @p -> SpecSig {}) = True
isPragLSig (unXRec @p -> InlineSig {}) = True
isPragLSig (unXRec @p -> SCCFunSig {}) = True
+isPragLSig (unXRec @p -> CallerCcSig {}) = True
isPragLSig (unXRec @p -> CompleteMatchSig {}) = True
-isPragLSig _ = False
+isPragLSig _ = False
isInlineLSig :: forall p. UnXRec p => LSig p -> Bool
-- Identifies inline pragmas
@@ -1124,6 +1133,10 @@ isSCCFunSig :: forall p. UnXRec p => LSig p -> Bool
isSCCFunSig (unXRec @p -> SCCFunSig {}) = True
isSCCFunSig _ = False
+isCallerCCSig :: forall p. UnXRec p => LSig p -> Bool
+isCallerCCSig (unXRec @p -> CallerCcSig {}) = True
+isCallerCCSig _ = False
+
isCompleteMatchSig :: forall p. UnXRec p => LSig p -> Bool
isCompleteMatchSig (unXRec @p -> CompleteMatchSig {} ) = True
isCompleteMatchSig _ = False
@@ -1143,6 +1156,7 @@ hsSigDoc (SpecInstSig _ src _)
hsSigDoc (FixSig {}) = text "fixity declaration"
hsSigDoc (MinimalSig {}) = text "MINIMAL pragma"
hsSigDoc (SCCFunSig {}) = text "SCC pragma"
+hsSigDoc (CallerCcSig {}) = text "CALLER_CC pragma"
hsSigDoc (CompleteMatchSig {}) = text "COMPLETE pragma"
hsSigDoc (XSig {}) = text "XSIG TTG extension"
@@ -1180,6 +1194,8 @@ ppr_sig (PatSynSig _ names sig_ty)
= text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty)
ppr_sig (SCCFunSig _ src fn mlabel)
= pragSrcBrackets src "{-# SCC" (ppr fn <+> maybe empty ppr mlabel )
+ppr_sig (CallerCcSig _ src fn)
+ = pragSrcBrackets src "{-# CALLER_CC" (ppr fn)
ppr_sig (CompleteMatchSig _ src cs mty)
= pragSrcBrackets src "{-# COMPLETE"
((hsep (punctuate comma (map ppr (unLoc cs))))
=====================================
compiler/GHC/Hs/Extension.hs
=====================================
@@ -370,6 +370,7 @@ type family XSpecSig x
type family XSpecInstSig x
type family XMinimalSig x
type family XSCCFunSig x
+type family XCallerCcSig x
type family XCompleteMatchSig x
type family XXSig x
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -993,6 +993,7 @@ rep_sig (L loc (SpecSig _ nm tys ispec))
rep_sig (L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty loc
rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty
rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty
+rep_sig (L _ (CallerCcSig {})) = notHandled "CALLER_CC pragmas" empty
rep_sig (L loc (CompleteMatchSig _ _st cls mty))
= rep_complete_sig cls mty loc
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -353,6 +353,7 @@ data IfaceInfoItem
| HsNoCafRefs
| HsLevity -- Present <=> never levity polymorphic
| HsLFInfo IfaceLFInfo
+ | HsWantsCallerCc
-- NB: Specialisations and rules come in separately and are
-- only later attached to the Id. Partial reason: some are orphans.
@@ -1460,6 +1461,7 @@ instance Outputable IfaceInfoItem where
ppr HsNoCafRefs = text "HasNoCafRefs"
ppr HsLevity = text "Never levity-polymorphic"
ppr (HsLFInfo lf_info) = text "LambdaFormInfo:" <+> ppr lf_info
+ ppr HsWantsCallerCc = text "WantsCallerCC"
instance Outputable IfaceJoinInfo where
ppr IfaceNotJoinPoint = empty
@@ -2223,6 +2225,7 @@ instance Binary IfaceInfoItem where
put_ bh HsLevity = putByte bh 5
put_ bh (HsCpr cpr) = putByte bh 6 >> put_ bh cpr
put_ bh (HsLFInfo lf_info) = putByte bh 7 >> put_ bh lf_info
+ put_ bh HsWantsCallerCc = putByte bh 8
get bh = do
h <- getByte bh
@@ -2236,7 +2239,9 @@ instance Binary IfaceInfoItem where
4 -> return HsNoCafRefs
5 -> return HsLevity
6 -> HsCpr <$> get bh
- _ -> HsLFInfo <$> get bh
+ 7 -> HsLFInfo <$> get bh
+ 8 -> return HsWantsCallerCc
+ _ -> fail "Binary(IfaceInfoItem): Invalid value"
instance Binary IfaceUnfolding where
put_ bh (IfCoreUnfold s e) = do
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -1491,6 +1491,7 @@ tcIdInfo ignore_prags toplvl name ty info = do
tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs)
+ tcPrag info HsWantsCallerCc = return (info `setCallerCcInfo` WantsCallerCc)
tcPrag info (HsArity arity) = return (info `setArityInfo` arity)
tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str)
tcPrag info (HsCpr cpr) = return (info `setCprInfo` cpr)
=====================================
compiler/GHC/Parser.y
=====================================
@@ -527,6 +527,7 @@ are the most common patterns, rewritten as regular expressions for clarity:
'{-# OVERLAPS' { L _ (IToverlaps_prag _) }
'{-# INCOHERENT' { L _ (ITincoherent_prag _) }
'{-# COMPLETE' { L _ (ITcomplete_prag _) }
+ '{-# CALLER_CC' { L _ (ITcaller_cc_prag _) }
'#-}' { L _ ITclose_prag }
'..' { L _ ITdotdot } -- reserved symbols
@@ -2397,6 +2398,10 @@ sigdecl :: { LHsDecl GhcPs }
(snd $2)))))
((mo $1:fst $2) ++ [mc $4]) }
+ | '{-# CALLER_CC' qvar '#-}'
+ {% ams ((sLL $1 $> $ SigD noExtField (CallerCcSig noExtField (getCALLER_CC_PRAGs $1) $2)))
+ [mo $1, mc $3] }
+
| '{-# SCC' qvar '#-}'
{% ams (sLL $1 $> (SigD noExtField (SCCFunSig noExtField (getSCC_PRAGs $1) $2 Nothing)))
[mo $1, mc $3] }
@@ -3681,6 +3686,7 @@ getINLINE (L _ (ITinline_prag _ inl conl)) = (inl,conl)
getSPEC_INLINE (L _ (ITspec_inline_prag _ True)) = (Inline, FunLike)
getSPEC_INLINE (L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike)
getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x
+getCALLER_CC_PRAGs (L _ (ITcaller_cc_prag x)) = x
getVOCURLY (L (RealSrcSpan l _) ITvocurly) = srcSpanStartCol l
getINTEGERs (L _ (ITinteger (IL src _ _))) = src
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -758,6 +758,7 @@ data Token
| IToverlaps_prag SourceText -- instance overlap mode
| ITincoherent_prag SourceText -- instance overlap mode
| ITctype SourceText
+ | ITcaller_cc_prag SourceText
| ITcomment_line_prag -- See Note [Nested comment line pragmas]
| ITdotdot -- reserved symbols
@@ -3298,6 +3299,7 @@ oneWordPrags = Map.fromList [
("incoherent", strtoken (\s -> ITincoherent_prag (SourceText s))),
("ctype", strtoken (\s -> ITctype (SourceText s))),
("complete", strtoken (\s -> ITcomplete_prag (SourceText s))),
+ ("caller_cc", strtoken (\s -> ITcaller_cc_prag (SourceText s))),
("column", columnPrag)
]
=====================================
compiler/GHC/Rename/Bind.hs
=====================================
@@ -1027,6 +1027,10 @@ renameSig ctxt sig@(SCCFunSig _ st v s)
= do { new_v <- lookupSigOccRn ctxt sig v
; return (SCCFunSig noExtField st new_v s, emptyFVs) }
+renameSig ctxt sig@(CallerCcSig _ st v)
+ = do { new_v <- lookupSigOccRn ctxt sig v
+ ; return (CallerCcSig noExtField st new_v, emptyFVs) }
+
-- COMPLETE Sigs can refer to imported IDs which is why we use
-- lookupLocatedOccRn rather than lookupSigOccRn
renameSig _ctxt sig@(CompleteMatchSig _ s (L l bf) mty)
@@ -1109,6 +1113,9 @@ okHsSig ctxt (L _ sig)
(SCCFunSig {}, HsBootCtxt {}) -> False
(SCCFunSig {}, _) -> True
+ (CallerCcSig {}, HsBootCtxt {}) -> False
+ (CallerCcSig {}, _) -> True
+
(CompleteMatchSig {}, TopSigCtxt {} ) -> True
(CompleteMatchSig {}, _) -> False
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -46,7 +46,9 @@ import GHC.Driver.Session
import GHC.Driver.Backend
import GHC.Driver.Ppr
import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars )
-import GHC.Types.Id ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId )
+import GHC.Types.Id ( Id, idName, idType, mkLocalId,
+ idInlinePragma, setInlinePragma, setIdCallerCcInfo )
+import GHC.Types.Id.Info ( CallerCcInfo(..) )
import GHC.Builtin.Names( mkUnboundName )
import GHC.Types.Basic
import GHC.Unit.Module( getModule )
@@ -570,6 +572,8 @@ mkPragEnv sigs binds
= Just (nm, L l $ InlineSig x lnm (add_arity nm inl))
get_sig (L l (SCCFunSig x st lnm@(L _ nm) str))
= Just (nm, L l $ SCCFunSig x st lnm str)
+ get_sig (L l (CallerCcSig x st lnm@(L _ nm)))
+ = Just (nm, L l $ CallerCcSig x st lnm)
get_sig _ = Nothing
add_arity n inl_prag -- Adjust inl_sat field to match visible arity of function
@@ -598,12 +602,23 @@ lhsBindArity _ env = env -- PatBind/VarBind
-- | Attach information from pragmas to an 'Id'\'s 'IdInfo'.
addIdPrags :: TcId -> [LSig GhcRn] -> TcM TcId
addIdPrags poly_id prags_for_me
- = addInlinePrags poly_id prags_for_me
+ = do poly_id' <- addCallerCcPrag poly_id prags_for_me
+ addInlinePrags poly_id' prags_for_me
+
+addCallerCcPrag :: TcId -> [LSig GhcRn] -> TcM TcId
+addCallerCcPrag poly_id prags_for_me
+ | _ : _ <- ccc_prags
+ = do { -- TODO: Warn on multiple pragmas
+ ; return (setIdCallerCcInfo poly_id WantsCallerCc) }
+ | otherwise
+ = return poly_id
+ where
+ ccc_prags = [loc | L loc (CallerCcSig _ _ _) <- prags_for_me]
-addInlinePrags :: TcId -> [LSig GhcRc] -> TcM TcId
+addInlinePrags :: TcId -> [LSig GhcRn] -> TcM TcId
addInlinePrags poly_id prags_for_me
| inl@(L _ prag) : inls <- inl_prags
- = do { traceTc "addInlinePrag" (ppr poly_id $$ ppr prag)
+ = do { traceTc "addIdPrags" (ppr poly_id $$ ppr prag)
; unless (null inls) (warn_multiple_inlines inl inls)
; return (poly_id `setInlinePragma` prag) }
| otherwise
@@ -751,7 +766,7 @@ tcSpecPrags poly_id prag_sigs
where
spec_sigs = filter isSpecLSig prag_sigs
bad_sigs = filter is_bad_sig prag_sigs
- is_bad_sig s = not (isSpecLSig s || isInlineLSig s || isSCCFunSig s)
+ is_bad_sig s = not (isSpecLSig s || isInlineLSig s || isSCCFunSig s || isCallerCCSig s)
warn_discarded_sigs
= addWarnTc NoReason
=====================================
compiler/GHC/Types/Id.hs
=====================================
@@ -100,6 +100,7 @@ module GHC.Types.Id (
isNeverLevPolyId,
-- ** Writing 'IdInfo' fields
+ setIdCallerCcInfo,
setIdUnfolding, setCaseBndrEvald,
setIdArity,
setIdCallArity,
@@ -169,6 +170,7 @@ infixl 1 `setIdUnfolding`,
`setIdCallArity`,
`setIdOccInfo`,
`setIdOneShotInfo`,
+ `setIdCallerCcInfo`,
`setIdSpecialisation`,
`setInlinePragma`,
@@ -645,6 +647,9 @@ asJoinId_maybe id Nothing = zapJoinId id
************************************************************************
-}
+setIdCallerCcInfo :: Id -> CallerCcInfo -> Id
+setIdCallerCcInfo id ccinfo = modifyIdInfo (`setCallerCcInfo` ccinfo) id
+
---------------------------------
-- ARITY
idArity :: Id -> Arity
=====================================
compiler/GHC/Types/Id/Info.hs
=====================================
@@ -46,6 +46,10 @@ module GHC.Types.Id.Info (
cprInfo, setCprInfo,
demandInfo, setDemandInfo, pprStrictness,
+ -- ** Caller-CC Info
+ callerCcInfo, setCallerCcInfo,
+ CallerCcInfo(..),
+
-- ** Unfolding Info
unfoldingInfo, setUnfoldingInfo,
@@ -287,6 +291,7 @@ data IdInfo
-- - Bit 0 (1): OneShotInfo
-- - Bit 1 (1): CafInfo
-- - Bit 2 (1): LevityInfo
+-- - Bit 3 (1): CallerCcInfo
-- - Bits 16-32(16): Call Arity info
-- - Bits 32-48(16): Arity info
--
@@ -307,6 +312,10 @@ bitfieldGetLevityInfo :: BitField -> LevityInfo
bitfieldGetLevityInfo (BitField bits) =
if testBit bits 2 then NeverLevityPolymorphic else NoLevityInfo
+bitfieldGetCallerCcInfo :: BitField -> CallerCcInfo
+bitfieldGetCallerCcInfo (BitField bits) =
+ if testBit bits 3 then WantsCallerCc else NoCallerCc
+
bitfieldGetCallArityInfo :: BitField -> ArityInfo
bitfieldGetCallArityInfo bf =
fromIntegral $ getBits bitRangeCallArityInfo bf
@@ -333,6 +342,12 @@ bitfieldSetLevityInfo info (BitField bits) =
NoLevityInfo -> BitField (clearBit bits 2)
NeverLevityPolymorphic -> BitField (setBit bits 2)
+bitfieldSetCallerCcInfo :: CallerCcInfo -> BitField -> BitField
+bitfieldSetCallerCcInfo info (BitField bits) =
+ case info of
+ NoCallerCc -> BitField (clearBit bits 3)
+ WantsCallerCc -> BitField (setBit bits 3)
+
bitfieldSetCallArityInfo :: ArityInfo -> BitField -> BitField
bitfieldSetCallArityInfo info bf =
setBits bitRangeCallArityInfo (fromIntegral info) bf
@@ -376,6 +391,9 @@ levityInfo = bitfieldGetLevityInfo . bitfield
oneShotInfo :: IdInfo -> OneShotInfo
oneShotInfo = bitfieldGetOneShotInfo . bitfield
+callerCcInfo :: IdInfo -> CallerCcInfo
+callerCcInfo = bitfieldGetCallerCcInfo . bitfield
+
-- | 'Id' arity, as computed by "GHC.Core.Opt.Arity". Specifies how many arguments
-- this 'Id' has to be applied to before it doesn any meaningful work.
arityInfo :: IdInfo -> ArityInfo
@@ -409,6 +427,10 @@ setUnfoldingInfo info uf
-- seqUnfolding uf `seq`
info { unfoldingInfo = uf }
+setCallerCcInfo :: IdInfo -> CallerCcInfo -> IdInfo
+setCallerCcInfo info cc =
+ info { bitfield = bitfieldSetCallerCcInfo cc (bitfield info) }
+
setArityInfo :: IdInfo -> ArityInfo -> IdInfo
setArityInfo info ar =
info { bitfield = bitfieldSetArityInfo ar (bitfield info) }
@@ -453,6 +475,7 @@ vanillaIdInfo
bitfieldSetCallArityInfo unknownArity $
bitfieldSetOneShotInfo NoOneShotInfo $
bitfieldSetLevityInfo NoLevityInfo $
+ bitfieldSetCallerCcInfo NoCallerCc $
emptyBitField,
lfInfo = Nothing
}
@@ -462,6 +485,9 @@ noCafIdInfo :: IdInfo
noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs
-- Used for built-in type Ids in GHC.Types.Id.Make.
+-- | Whether an 'Id' was marked with a @CALLER_CC@ pragma.
+data CallerCcInfo = WantsCallerCc | NoCallerCc
+
{-
************************************************************************
* *
=====================================
compiler/ghc.cabal.in
=====================================
@@ -433,6 +433,7 @@ Library
GHC.Core.Opt.Simplify.Monad
GHC.Core.Opt.Simplify.Utils
GHC.Core.Opt.Simplify
+ GHC.Core.AddCallerCcs
GHC.Stg.Pipeline
GHC.Stg.Stats
GHC.Stg.CSE
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e6c0d6b04f10c861066954fb3b2421f1d881720d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e6c0d6b04f10c861066954fb3b2421f1d881720d
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200813/0745492c/attachment-0001.html>
More information about the ghc-commits
mailing list