Add support for defining ticky tickers in Corewip/user-ticker

This allows the user to define new ticky tickers via a new Core Tickish
type, `TickyCtr`. These behave like source notes in the sense that they
try to interfere minimally with simplification. It is intended that they
be introduced by Core-to-Core plugins late in the Core pipeline.

17 files changed, 156 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.
diff --git a/testsuite/tests/codeGen/should_run/Makefile b/testsuite/tests/codeGen/should_run/Makefile
index 4a268530f1..1b2770bf54 100644
--- a/testsuite/tests/codeGen/should_run/Makefile
+++ b/testsuite/tests/codeGen/should_run/Makefile
@@ -2,3 +2,7 @@ TOP=../../..
 include $(TOP)/mk/boilerplate.mk
 include $(TOP)/mk/test.mk
 
+UserTickyCounter :
+	"$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 -package-db user-ticky-counter-plugin/pkg/local.package.conf -fplugin=UserTickyCounterPlugin -ticky UserTickyCounter
+	./UserTickyCounter +RTS -rticky
+	cat ticky
diff --git a/testsuite/tests/codeGen/should_run/UserTickyCounter.hs b/testsuite/tests/codeGen/should_run/UserTickyCounter.hs
new file mode 100644
index 0000000000..962a1c4c7e
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/UserTickyCounter.hs
@@ -0,0 +1,8 @@
+module Main where
+
+fib :: Integer -> Integer
+fib 0 = 1
+fib 1 = 1
+fib n = fib (n-1) + fib (n-2)
+
+main = print $ fib 10
diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T
index 36772a7840..762c8de5be 100644
--- a/testsuite/tests/codeGen/should_run/all.T
+++ b/testsuite/tests/codeGen/should_run/all.T
@@ -219,3 +219,8 @@ test('CallConv', [when(unregisterised(), skip),
                   when(arch('x86_64'), extra_hc_opts('CallConv_x86_64.s')),
                   when(arch('aarch64'), extra_hc_opts('CallConv_aarch64.s'))],
      compile_and_run, [''])
+
+test('UserTickyCounter',
+     [extra_files(['user-ticky-counter-plugin/']),
+     pre_cmd('$MAKE -s --no-print-directory -C user-ticky-counter-plugin/ package TOP={top}')],
+     makefile_test, [])
diff --git a/testsuite/tests/codeGen/should_run/user-ticky-counter-plugin/Makefile b/testsuite/tests/codeGen/should_run/user-ticky-counter-plugin/Makefile
new file mode 100644
index 0000000000..ed1f887571
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/user-ticky-counter-plugin/Makefile
@@ -0,0 +1,18 @@
+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+HERE := $(abspath .)
+$(eval $(call canonicalise,HERE))
+
+package:
+	rm -R pkg
+	mkdir pkg
+	"$(TEST_HC)" -outputdir pkg --make -v0 -o pkg/setup Setup.hs
+	
+	"$(GHC_PKG)" init pkg/local.package.conf
+	
+	pkg/setup configure --distdir pkg/dist -v0 $(CABAL_PLUGIN_BUILD) --prefix="$(HERE)/pkg/install" --with-compiler="$(TEST_HC)" --with-hc-pkg="$(GHC_PKG)" --package-db=pkg/local.package.conf $(if $(findstring YES,$(HAVE_PROFILING)), --enable-library-profiling)
+	pkg/setup build     --distdir pkg/dist -v0
+	pkg/setup install   --distdir pkg/dist -v0
+
diff --git a/testsuite/tests/codeGen/should_run/user-ticky-counter-plugin/Setup.hs b/testsuite/tests/codeGen/should_run/user-ticky-counter-plugin/Setup.hs
new file mode 100644
index 0000000000..6479cb1c16
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/user-ticky-counter-plugin/Setup.hs
@@ -0,0 +1,4 @@
+import Distribution.Simple
+
+main = defaultMain
+
diff --git a/testsuite/tests/codeGen/should_run/user-ticky-counter-plugin/UserTickyCounterPlugin.hs b/testsuite/tests/codeGen/should_run/user-ticky-counter-plugin/UserTickyCounterPlugin.hs
new file mode 100644
index 0000000000..d9d887501f
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/user-ticky-counter-plugin/UserTickyCounterPlugin.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE TupleSections #-}
+
+module UserTickyCounterPlugin (plugin) where
+
+import GHC.Plugins
+import GHC.Types.Tickish
+import Prelude hiding ((<>))
+
+plugin :: Plugin
+plugin =
+    defaultPlugin { installCoreToDos = \_args todos -> return $ todos ++ [corePlugin] }
+
+corePlugin :: CoreToDo
+corePlugin = CoreDoPluginPass "add tickers" (bindsOnlyPass addTickers)
+
+addTickers :: CoreProgram -> CoreM CoreProgram
+addTickers binds = mapM addTicker binds
+
+addTicker :: CoreBind -> CoreM CoreBind
+addTicker (NonRec bndr rhs) = NonRec bndr <$> addTick bndr rhs
+addTicker (Rec bs)          = Rec <$> mapM (\(bndr, rhs) -> (bndr,) <$> addTick bndr rhs) bs
+
+addTick :: Id -> CoreExpr -> CoreM CoreExpr
+addTick bndr rhs = do
+    u <- getUniqueM
+    dflags <- getDynFlags
+    let tickish = TickyCounter $ showSDoc dflags $ text "hi" <> ppr bndr <> ppr u
+    return $ Tick tickish rhs
diff --git a/testsuite/tests/codeGen/should_run/user-ticky-counter-plugin/user-ticky-counter-plugin.cabal b/testsuite/tests/codeGen/should_run/user-ticky-counter-plugin/user-ticky-counter-plugin.cabal
new file mode 100644
index 0000000000..4cecf90b29
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/user-ticky-counter-plugin/user-ticky-counter-plugin.cabal
@@ -0,0 +1,13 @@
+Name:           user-ticky-counter-plugin
+Version:        0.1
+Cabal-Version:  >= 1.2
+Build-Type:     Simple
+License:        BSD3
+Author:         Ben Gamari
+
+Library
+    Build-Depends:
+        base,
+        ghc >= 6.11
+    Exposed-Modules:
+        UserTickyCounterPlugin