Counters for characterising mkTyConApp branchwip/mkTyConApp-counters

2 files changed, 69 insertions, 4 deletions

diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs
index 3af971c101..b709d1996c 100644
--- a/compiler/GHC/Core/Type.hs
+++ b/compiler/GHC/Core/Type.hs
@@ -32,6 +32,7 @@ module GHC.Core.Type (
         splitFunTys, funResultTy, funArgTy,
 
         mkTyConApp, mkTyConTy,
+        reportCounters, mkTyConAppCounters,
         tyConAppTyCon_maybe, tyConAppTyConPicky_maybe,
         tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs,
         splitTyConApp_maybe, splitTyConApp, tyConAppArgN,
@@ -232,6 +233,8 @@ import GHC.Core.TyCo.Rep
 import GHC.Core.TyCo.Subst
 import GHC.Core.TyCo.Tidy
 import GHC.Core.TyCo.FVs
+import System.IO.Unsafe (unsafePerformIO)
+import Data.IORef
 
 -- friends:
 import Var
@@ -1227,20 +1230,80 @@ compilation. In order to avoid a potentially expensive series of checks in
                                 ~~~~~~~~
 -}
 
+data Counter = Counter {counterName :: String, counterRef :: IORef Int}
+
+-- | Counters created with this must be @NOINLINE@.
+newCounter :: String -> Counter
+newCounter s = unsafePerformIO (Counter s <$> newIORef 0)
+
+bumpCounter :: Counter -> a -> a
+bumpCounter (Counter _ ref) x = unsafePerformIO $ do
+    atomicModifyIORef' ref (\n -> (n+1, ()))
+    return x
+{-# NOINLINE bumpCounter #-}
+
+bumpCounter' :: Counter -> b -> a -> a
+bumpCounter' (Counter _ ref) y x = unsafePerformIO $ do
+    atomicModifyIORef' ref (\n -> (n+1, ()))
+    y `seq` return x
+{-# NOINLINE bumpCounter' #-}
+
+getCounter :: Counter -> IO Int
+getCounter = readIORef  . counterRef
+
+reportCounters :: [Counter] -> IO ()
+reportCounters = mapM_ f
+  where
+    f c = do
+      n <- getCounter c
+      putStrLn $ counterName c ++ " " ++ show n
+
+mkTyConAppCounters :: [Counter]
+mkTyConAppCounters =
+  [ mkTyConAppCnt
+  , mkTyConAppFunCnt
+  , mkTyConAppTypeCnt
+  , mkTyConAppTYPECnt
+  , mkTyConAppNewCnt
+  ]
+
+mkTyConAppCnt :: Counter 
+mkTyConAppCnt = newCounter "mkTyConApp"
+{-# NOINLINE mkTyConAppCnt #-}
+
+mkTyConAppFunCnt :: Counter 
+mkTyConAppFunCnt = newCounter "mkTyConAppFun"
+{-# NOINLINE mkTyConAppFunCnt #-}
+
+mkTyConAppTypeCnt :: Counter 
+mkTyConAppTypeCnt = newCounter "mkTyConAppType"
+{-# NOINLINE mkTyConAppTypeCnt #-}
+
+mkTyConAppTYPECnt :: Counter 
+mkTyConAppTYPECnt = newCounter "mkTyConAppTYPE"
+{-# NOINLINE mkTyConAppTYPECnt #-}
+
+mkTyConAppNewCnt :: Counter 
+mkTyConAppNewCnt = newCounter "mkTyConAppNew"
+{-# NOINLINE mkTyConAppNewCnt #-}
+
 -- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to
 -- its arguments.  Applies its arguments to the constructor from left to right.
 mkTyConApp :: TyCon -> [Type] -> Type
 mkTyConApp tycon tys
-  | isFunTyCon tycon
+  | bumpCounter mkTyConAppCnt $ isFunTyCon tycon
   , [_rep1,_rep2,ty1,ty2] <- tys
   -- The FunTyCon (->) is always a visible one
-  = FunTy { ft_af = VisArg, ft_arg = ty1, ft_res = ty2 }
+  = bumpCounter mkTyConAppFunCnt $ FunTy { ft_af = VisArg, ft_arg = ty1, ft_res = ty2 }
   -- Note [mkTyConApp and Type]
   | tycon == liftedTypeKindTyCon
   = ASSERT2( null tys, ppr tycon $$ ppr tys )
-    liftedTypeKindTyConApp
+    bumpCounter' mkTyConAppTypeCnt tys $ liftedTypeKindTyConApp
+  | tycon == tYPETyCon
+  , [rep] <- tys
+  = bumpCounter' mkTyConAppTYPECnt rep $ tYPE rep
   | otherwise
-  = TyConApp tycon tys
+  = bumpCounter mkTyConAppNewCnt $ TyConApp tycon tys
 
 -- This is a single, global definition of the type `Type`
 -- Defined here so it is only allocated once.
diff --git a/ghc/Main.hs b/ghc/Main.hs
index 1ad2a26e86..7ddb20ffbf 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -25,6 +25,7 @@ import GHC.Driver.CmdLine
 -- Implementations of the various modes (--show-iface, mkdependHS. etc.)
 import GHC.Iface.Load       ( showIface )
 import GHC.Driver.Main      ( newHscEnv )
+import GHC.Core.Type     ( mkTyConAppCounters, reportCounters)
 import GHC.Driver.Pipeline  ( oneShot, compileFile )
 import GHC.Driver.MakeFile  ( doMkDependHS )
 import GHC.Driver.Backpack  ( doBackpack )
@@ -278,6 +279,7 @@ main' postLoadMode dflags0 args flagWarnings = do
        DoBackpack             -> doBackpack (map fst srcs)
 
   liftIO $ dumpFinalStats dflags6
+  liftIO $ reportCounters mkTyConAppCounters
 
 ghciUI :: HscEnv -> DynFlags -> [(FilePath, Maybe Phase)] -> Maybe [String]
        -> Ghc ()