summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC/Cmm/CLabel.hs17
-rw-r--r--compiler/GHC/Core/Ppr.hs2
-rw-r--r--compiler/GHC/Core/Seq.hs1
-rw-r--r--compiler/GHC/CoreToIface.hs1
-rw-r--r--compiler/GHC/CoreToStg.hs1
-rw-r--r--compiler/GHC/Iface/Syntax.hs19
-rw-r--r--compiler/GHC/IfaceToCore.hs1
-rw-r--r--compiler/GHC/StgToCmm/Expr.hs1
-rw-r--r--compiler/GHC/StgToCmm/Ticky.hs29
-rw-r--r--compiler/GHC/Types/Tickish.hs12
10 files changed, 76 insertions, 8 deletions
diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs
index 723970e520..314b91a26c 100644
--- a/compiler/GHC/Cmm/CLabel.hs
+++ b/compiler/GHC/Cmm/CLabel.hs
@@ -90,6 +90,7 @@ module GHC.Cmm.CLabel (
mkPicBaseLabel,
mkDeadStripPreventer,
mkHpcTicksLabel,
+ mkUserTickyCtrLabel,
-- * Predicates
hasCAF,
@@ -277,6 +278,8 @@ data CLabel
-- | Per-module table of tick locations
| HpcTicksLabel Module
+ | UserTickyCtrLabel Module !Unique
+
-- | Static reference table
| SRTLabel
{-# UNPACK #-} !Unique
@@ -365,6 +368,8 @@ instance Ord CLabel where
compare a1 a2
compare (HpcTicksLabel a1) (HpcTicksLabel a2) =
compare a1 a2
+ compare (UserTickyCtrLabel a1 b1) (UserTickyCtrLabel a2 b2) =
+ compare a1 a2 `thenCmp` nonDetCmpUnique b1 b2
compare (SRTLabel u1) (SRTLabel u2) =
nonDetCmpUnique u1 u2
compare (LargeBitmapLabel u1) (LargeBitmapLabel u2) =
@@ -397,6 +402,8 @@ instance Ord CLabel where
compare _ DeadStripPreventer{} = GT
compare HpcTicksLabel{} _ = LT
compare _ HpcTicksLabel{} = GT
+ compare UserTickyCtrLabel{} _ = LT
+ compare _ UserTickyCtrLabel{} = GT
compare SRTLabel{} _ = LT
compare _ SRTLabel{} = GT
compare (IPE_Label {}) _ = LT
@@ -802,6 +809,10 @@ mkRtsSlowFastTickyCtrLabel pat = RtsLabel (RtsSlowFastTickyCtr pat)
mkHpcTicksLabel :: Module -> CLabel
mkHpcTicksLabel = HpcTicksLabel
+-- Constructing labels for user-provided ticky tickers
+mkUserTickyCtrLabel :: Module -> Unique -> CLabel
+mkUserTickyCtrLabel = UserTickyCtrLabel
+
-- Constructing labels used for dynamic linking
mkDynamicLinkerLabel :: DynamicLinkerLabelInfo -> CLabel -> CLabel
@@ -946,6 +957,7 @@ needsCDecl (CC_Label _) = True
needsCDecl (CCS_Label _) = True
needsCDecl (IPE_Label {}) = True
needsCDecl (HpcTicksLabel _) = True
+needsCDecl (UserTickyCtrLabel _ _) = True
needsCDecl (DynamicLinkerLabel {}) = panic "needsCDecl DynamicLinkerLabel"
needsCDecl PicBaseLabel = panic "needsCDecl PicBaseLabel"
needsCDecl (DeadStripPreventer {}) = panic "needsCDecl DeadStripPreventer"
@@ -1070,6 +1082,7 @@ externallyVisibleCLabel (CCS_Label _) = True
externallyVisibleCLabel (IPE_Label {}) = True
externallyVisibleCLabel (DynamicLinkerLabel _ _) = False
externallyVisibleCLabel (HpcTicksLabel _) = True
+externallyVisibleCLabel (UserTickyCtrLabel _ _) = True
externallyVisibleCLabel (LargeBitmapLabel _) = False
externallyVisibleCLabel (SRTLabel _) = False
externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel"
@@ -1132,6 +1145,7 @@ labelType (DynamicLinkerLabel _ _) = DataLabel -- Is this right?
labelType PicBaseLabel = DataLabel
labelType (DeadStripPreventer _) = DataLabel
labelType (HpcTicksLabel _) = DataLabel
+labelType (UserTickyCtrLabel _ _) = DataLabel
labelType (LargeBitmapLabel _) = DataLabel
idInfoLabelType :: IdLabelInfo -> CLabelType
@@ -1449,6 +1463,9 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel]
HpcTicksLabel mod
-> maybe_underscore $ text "_hpc_tickboxes_" <> ppr mod <> text "_hpc"
+ UserTickyCtrLabel mod u
+ -> maybe_underscore $ text "_ticky_user_" <> ppr mod <> text "_" <> pprUniqueAlways u <> text "_ctr"
+
CC_Label cc -> maybe_underscore $ ppr cc
CCS_Label ccs -> maybe_underscore $ ppr ccs
IPE_Label (InfoProvEnt l _ _ m _) -> maybe_underscore $ (pprCode CStyle (pdoc platform l) <> text "_" <> ppr m <> text "_ipe")
diff --git a/compiler/GHC/Core/Ppr.hs b/compiler/GHC/Core/Ppr.hs
index f1791dfebf..0540e05609 100644
--- a/compiler/GHC/Core/Ppr.hs
+++ b/compiler/GHC/Core/Ppr.hs
@@ -674,3 +674,5 @@ instance Outputable (XTickishId pass) => Outputable (GenTickish pass) where
_ -> hcat [text "scc<", ppr cc, char '>']
ppr (SourceNote span _) =
hcat [ text "src<", pprUserRealSpan True span, char '>']
+ ppr (TickyCounter mod name) =
+ hcat [ text "ticker<", ppr mod <+> text name, char '>']
diff --git a/compiler/GHC/Core/Seq.hs b/compiler/GHC/Core/Seq.hs
index 0addae9775..6d822c95b4 100644
--- a/compiler/GHC/Core/Seq.hs
+++ b/compiler/GHC/Core/Seq.hs
@@ -77,6 +77,7 @@ seqTickish ProfNote{ profNoteCC = cc } = cc `seq` ()
seqTickish HpcTick{} = ()
seqTickish Breakpoint{ breakpointFVs = ids } = seqBndrs ids
seqTickish SourceNote{} = ()
+seqTickish TickyCounter{} = ()
seqBndr :: CoreBndr -> ()
seqBndr b | isTyVar b = seqType (tyVarKind b)
diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs
index 2a4e6c9f33..a84c926a2b 100644
--- a/compiler/GHC/CoreToIface.hs
+++ b/compiler/GHC/CoreToIface.hs
@@ -571,6 +571,7 @@ toIfaceOneShot id | isId id
toIfaceTickish :: CoreTickish -> Maybe IfaceTickish
toIfaceTickish (ProfNote cc tick push) = Just (IfaceSCC cc tick push)
toIfaceTickish (HpcTick modl ix) = Just (IfaceHpcTick modl ix)
+toIfaceTickish (TickyCounter mod name) = Just (IfaceTickyCounter mod name)
toIfaceTickish (SourceNote src names) = Just (IfaceSource src names)
toIfaceTickish (Breakpoint {}) = Nothing
-- Ignore breakpoints, since they are relevant only to GHCi, and
diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs
index 8d99965513..a71973af20 100644
--- a/compiler/GHC/CoreToStg.hs
+++ b/compiler/GHC/CoreToStg.hs
@@ -630,6 +630,7 @@ coreToStgTick _ty (HpcTick m i) = HpcTick m i
coreToStgTick _ty (SourceNote span nm) = SourceNote span nm
coreToStgTick _ty (ProfNote cc cnt scope) = ProfNote cc cnt scope
coreToStgTick !ty (Breakpoint _ bid fvs) = Breakpoint ty bid fvs
+coreToStgTick _ty (TickyCounter mod nm) = TickyCounter mod nm
-- ---------------------------------------------------------------------------
-- The magic for lets:
diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs
index 39f0bd5336..b98de31db6 100644
--- a/compiler/GHC/Iface/Syntax.hs
+++ b/compiler/GHC/Iface/Syntax.hs
@@ -563,6 +563,7 @@ data IfaceExpr
data IfaceTickish
= IfaceHpcTick Module Int -- from HpcTick x
+ | IfaceTickyCounter Module String -- from TickyCounter
| IfaceSCC CostCentre Bool Bool -- from ProfNote
| IfaceSource RealSrcSpan String -- from SourceNote
-- no breakpoints: we never export these into interface files
@@ -1439,6 +1440,8 @@ ppr_bind (IfLetBndr b ty info ji, rhs)
pprIfaceTickish :: IfaceTickish -> SDoc
pprIfaceTickish (IfaceHpcTick m ix)
= braces (text "tick" <+> ppr m <+> ppr ix)
+pprIfaceTickish (IfaceTickyCounter m n)
+ = braces (text "ticker" <+> ppr m <+> ppr n)
pprIfaceTickish (IfaceSCC cc tick scope)
= braces (pprCostCentreCore cc <+> ppr tick <+> ppr scope)
pprIfaceTickish (IfaceSource src _names)
@@ -2409,13 +2412,17 @@ instance Binary IfaceTickish where
putByte bh 0
put_ bh m
put_ bh ix
- put_ bh (IfaceSCC cc tick push) = do
+ put_ bh (IfaceTickyCounter m n) = do
putByte bh 1
+ put_ bh m
+ put_ bh n
+ put_ bh (IfaceSCC cc tick push) = do
+ putByte bh 2
put_ bh cc
put_ bh tick
put_ bh push
put_ bh (IfaceSource src name) = do
- putByte bh 2
+ putByte bh 3
put_ bh (srcSpanFile src)
put_ bh (srcSpanStartLine src)
put_ bh (srcSpanStartCol src)
@@ -2429,11 +2436,14 @@ instance Binary IfaceTickish where
0 -> do m <- get bh
ix <- get bh
return (IfaceHpcTick m ix)
- 1 -> do cc <- get bh
+ 1 -> do m <- get bh
+ n <- get bh
+ return (IfaceTickyCounter m n)
+ 2 -> do cc <- get bh
tick <- get bh
push <- get bh
return (IfaceSCC cc tick push)
- 2 -> do file <- get bh
+ 3 -> do file <- get bh
sl <- get bh
sc <- get bh
el <- get bh
@@ -2656,6 +2666,7 @@ instance NFData IfaceJoinInfo where
instance NFData IfaceTickish where
rnf = \case
IfaceHpcTick m i -> rnf m `seq` rnf i
+ IfaceTickyCounter m n -> rnf m `seq` rnf n
IfaceSCC cc b1 b2 -> cc `seq` rnf b1 `seq` rnf b2
IfaceSource src str -> src `seq` rnf str
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index 0250078b62..be927ac1a2 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -1571,6 +1571,7 @@ tcIfaceExpr (IfaceTick tickish expr) = do
-------------------------
tcIfaceTickish :: IfaceTickish -> IfM lcl CoreTickish
tcIfaceTickish (IfaceHpcTick modl ix) = return (HpcTick modl ix)
+tcIfaceTickish (IfaceTickyCounter m n) = return (TickyCounter m n)
tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push)
tcIfaceTickish (IfaceSource src name) = return (SourceNote src name)
diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs
index 6355b55427..db58059cb1 100644
--- a/compiler/GHC/StgToCmm/Expr.hs
+++ b/compiler/GHC/StgToCmm/Expr.hs
@@ -1122,5 +1122,6 @@ cgTick tick
ProfNote cc t p -> emitSetCCC cc t p
HpcTick m n -> emit (mkTickBox platform m n)
SourceNote s n -> emitTick $ SourceNote s n
+ TickyCounter m n -> emitTickyUserCounter m n
_other -> return () -- ignore
}
diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs
index 6a30bfff75..0a7bda108d 100644
--- a/compiler/GHC/StgToCmm/Ticky.hs
+++ b/compiler/GHC/StgToCmm/Ticky.hs
@@ -73,6 +73,8 @@ module GHC.StgToCmm.Ticky (
withNewTickyCounterStdThunk,
withNewTickyCounterCon,
+ emitTickyUserCounter,
+
tickyDynAlloc,
tickyAllocHeap,
@@ -121,6 +123,7 @@ import GHC.Cmm.Utils
import GHC.Cmm.CLabel
import GHC.Runtime.Heap.Layout
+import GHC.Unit.Module
import GHC.Types.Name
import GHC.Types.Id
import GHC.Types.Basic
@@ -203,6 +206,19 @@ withNewTickyCounterCon name datacon code = do
then code
else withNewTickyCounter (TickyCon datacon) name [] code
+-- | Emit a ticker resulting from a 'TickyCounter' 'Tick'.
+emitTickyUserCounter :: Module -> String -> FCode ()
+emitTickyUserCounter mod name = ifTicky $ do
+ -- TODO: Make tickers weak symbols. Once we do so, take care to only emit
+ -- the counter when `this_mod == mod`
+ u <- newUnique
+ let ctr_lbl = mkUserTickyCtrLabel mod u
+ name' <- newStringCLit name
+ placeholder <- newStringCLit ""
+ emitRawTickyCounter ctr_lbl name' placeholder 0
+ registerTickyCtr ctr_lbl
+ bumpTickyLbl ctr_lbl
+
-- args does not include the void arguments
withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a
withNewTickyCounter cloType name args m = do
@@ -215,7 +231,6 @@ emitTickyCounter cloType name args
(>> return ctr_lbl) $
ifTicky $ do
{ dflags <- getDynFlags
- ; platform <- getPlatform
; parent <- getTickyCtrLabel
; mod_name <- getModuleName
@@ -247,15 +262,21 @@ emitTickyCounter cloType name args
{ sdocPprDebug = True }
; fun_descr_lit <- newStringCLit $ renderWithContext ctx ppr_for_ticky_name
; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . fromNonVoid) args
+ ; emitRawTickyCounter ctr_lbl fun_descr_lit arg_descr_lit (length args)
+ }
+
+emitRawTickyCounter :: CLabel -> CmmLit -> CmmLit -> Int -> FCode ()
+emitRawTickyCounter ctr_lbl fun_descr_lit arg_descr_lit arity = do
+ { platform <- getPlatform
; emitDataLits ctr_lbl
-- Must match layout of rts/include/rts/Ticky.h's StgEntCounter
--
-- krc: note that all the fields are I32 now; some were I16
-- before, but the code generator wasn't handling that
-- properly and it led to chaos, panic and disorder.
- [ mkIntCLit platform 0, -- registered?
- mkIntCLit platform (length args), -- Arity
- mkIntCLit platform 0, -- Heap allocated for this thing
+ [ mkIntCLit platform 0, -- registered?
+ mkIntCLit platform arity, -- Arity
+ mkIntCLit platform 0, -- Heap allocated for this thing
fun_descr_lit,
arg_descr_lit,
zeroCLit platform, -- Entries into this thing
diff --git a/compiler/GHC/Types/Tickish.hs b/compiler/GHC/Types/Tickish.hs
index b7d28c01d8..7d5deeedba 100644
--- a/compiler/GHC/Types/Tickish.hs
+++ b/compiler/GHC/Types/Tickish.hs
@@ -155,6 +155,16 @@ data GenTickish pass =
-- (uses same names as CCs)
}
+ -- | A Ticky counter. This is used to introduce Ticky-Ticky profiler
+ -- counters which are incremented when the enclosed scope is entered.
+ -- These behave like source notes in that they try to be as unobtrusive to
+ -- simplification as possible. Note that 'tickyCounterName' must be unique
+ -- per module.
+ | TickyCounter
+ { tickyCounterModule :: Module
+ , tickyCounterName :: String
+ }
+
deriving instance Eq (GenTickish 'TickishPassCore)
deriving instance Ord (GenTickish 'TickishPassCore)
deriving instance Data (GenTickish 'TickishPassCore)
@@ -253,6 +263,7 @@ tickishScoped Breakpoint{} = CostCentreScope
-- stacks, but also this helps prevent the simplifier from moving
-- breakpoints around and changing their result type (see #1531).
tickishScoped SourceNote{} = SoftScope
+tickishScoped TickyCounter{} = SoftScope
-- | Returns whether the tick scoping rule is at least as permissive
-- as the given scoping rule.
@@ -360,6 +371,7 @@ tickishPlace n@ProfNote{}
tickishPlace HpcTick{} = PlaceRuntime
tickishPlace Breakpoint{} = PlaceRuntime
tickishPlace SourceNote{} = PlaceNonLam
+tickishPlace TickyCounter{} = PlaceNonLam
-- | Returns whether one tick "contains" the other one, therefore
-- making the second tick redundant.
View Lorry Controller Status