diff options
-rw-r--r-- | compiler/GHC/Core/Type.hs | 71 | ||||
-rw-r--r-- | ghc/Main.hs | 2 |
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 () |