Fix histograms for ticky code

This patch fixes Cmm generation required to produce histograms when
compiling with -ticky flag, strips dead code from rts/Ticky.c and
reworks it to use a shared constant in both C and Haskell code.

Fixes #8308.

Test Plan: T8308

Reviewers: jstolarek, simonpj, austin

Reviewed By: simonpj

Subscribers: mpickering, simonpj, bgamari, mlen, thomie, jstolarek

Differential Revision: https://phabricator.haskell.org/D931

GHC Trac Issues: #8308

1 files changed, 11 insertions, 27 deletions

diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs
index d4f352c7d8..273e9c01bc 100644
--- a/compiler/codeGen/StgCmmTicky.hs
+++ b/compiler/codeGen/StgCmmTicky.hs
@@ -97,7 +97,7 @@ module StgCmmTicky (
 
   tickyUpdateBhCaf,
   tickyBlackHole,
-  tickyUnboxedTupleReturn, tickyVectoredReturn,
+  tickyUnboxedTupleReturn,
   tickyReturnOldCon, tickyReturnNewCon,
 
   tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,
@@ -376,11 +376,6 @@ tickyUnboxedTupleReturn arity
   = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr")
                  ; bumpHistogram    (fsLit "RET_UNBOXED_TUP_hst") arity }
 
-tickyVectoredReturn :: Int -> FCode ()
-tickyVectoredReturn family_size
-  = ifTicky $ do { bumpTickyCounter (fsLit "VEC_RETURN_ctr")
-                 ; bumpHistogram    (fsLit "RET_VEC_RETURN_hst") family_size }
-
 -- -----------------------------------------------------------------------------
 -- Ticky calls
 
@@ -615,26 +610,15 @@ bumpTickyLitByE lhs e = do
   emit (addToMemE (bWord dflags) (CmmLit lhs) e)
 
 bumpHistogram :: FastString -> Int -> FCode ()
-bumpHistogram _lbl _n
---  = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLongWidth))
-    = return ()    -- TEMP SPJ Apr 07
-                   -- six years passed - still temp? JS Aug 2013
-
-{-
-bumpHistogramE :: LitString -> CmmExpr -> FCode ()
-bumpHistogramE lbl n
-  = do  t <- newTemp cLong
-        emitAssign (CmmLocal t) n
-        emit (mkCmmIfThen (CmmMachOp (MO_U_Le cLongWidth) [CmmReg (CmmLocal t), eight])
-                          (mkAssign (CmmLocal t) eight))
-        emit (addToMem cLong
-                       (cmmIndexExpr cLongWidth
-                                (CmmLit (CmmLabel (mkRtsDataLabel lbl)))
-                                (CmmReg (CmmLocal t)))
-                       1)
-  where
-   eight = CmmLit (CmmInt 8 cLongWidth)
--}
+bumpHistogram lbl n = do
+    dflags <- getDynFlags
+    let offset = n `min` (tICKY_BIN_COUNT dflags - 1)
+    emit (addToMem (cLong dflags)
+           (cmmIndexExpr dflags
+                (cLongWidth dflags)
+                (CmmLit (CmmLabel (mkCmmDataLabel rtsUnitId lbl)))
+                (CmmLit (CmmInt (fromIntegral offset) (cLongWidth dflags))))
+           1)
 
 ------------------------------------------------------------------
 -- Showing the "type category" for ticky-ticky profiling
@@ -671,7 +655,7 @@ showTypeCategory ty
   | otherwise = case tcSplitTyConApp_maybe ty of
   Nothing -> '.'
   Just (tycon, _) ->
-    (if isUnliftedTyCon tycon then Data.Char.toLower else \x -> x) $
+    (if isUnliftedTyCon tycon then Data.Char.toLower else id) $
     let anyOf us = getUnique tycon `elem` us in
     case () of
       _ | anyOf [funTyConKey] -> '>'