\end{enumerate}
\begin{code}
+{-# OPTIONS -fno-warn-incomplete-patterns #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module StgStats ( showStgStats ) where
#include "HsVersions.h"
import StgSyn
-import FiniteMap ( emptyFM, plusFM_C, unitFM, fmToList, FiniteMap )
import Id (Id)
+
+import Data.Map (Map)
+import qualified Data.Map as Map
\end{code}
\begin{code}
deriving (Eq, Ord)
type Count = Int
-type StatEnv = FiniteMap CounterType Count
+type StatEnv = Map CounterType Count
\end{code}
\begin{code}
emptySE :: StatEnv
-emptySE = emptyFM
+emptySE = Map.empty
combineSE :: StatEnv -> StatEnv -> StatEnv
-combineSE = plusFM_C (+)
+combineSE = Map.unionWith (+)
combineSEs :: [StatEnv] -> StatEnv
combineSEs = foldr combineSE emptySE
countOne :: CounterType -> StatEnv
-countOne c = unitFM c 1
+countOne c = Map.singleton c 1
countN :: CounterType -> Int -> StatEnv
-countN = unitFM
+countN = Map.singleton
\end{code}
%************************************************************************
showStgStats prog
= "STG Statistics:\n\n"
- ++ concat (map showc (fmToList (gatherStgStats prog)))
+ ++ concat (map showc (Map.toList (gatherStgStats prog)))
where
showc (x,n) = (showString (s x) . shows n) "\n"
statRhs :: Bool -> (Id, StgRhs) -> StatEnv
-statRhs top (b, StgRhsCon cc con args)
+statRhs top (_, StgRhsCon _ _ _)
= countOne (ConstructorBinds top)
-statRhs top (b, StgRhsClosure cc bi fv u _srt args body)
+statRhs top (_, StgRhsClosure _ _ fv u _ _ body)
= statExpr body `combineSE`
countN FreeVariables (length fv) `combineSE`
countOne (
statExpr (StgLit _) = countOne Literals
statExpr (StgConApp _ _) = countOne ConstructorApps
statExpr (StgOpApp _ _ _) = countOne PrimitiveApps
-statExpr (StgSCC l e) = statExpr e
+statExpr (StgSCC _ e) = statExpr e
+statExpr (StgTick _ _ e) = statExpr e
-statExpr (StgLetNoEscape lvs_whole lvs_rhss binds body)
+statExpr (StgLetNoEscape _ _ binds body)
= statBinding False{-not top-level-} binds `combineSE`
statExpr body `combineSE`
countOne LetNoEscapes
= statBinding False{-not top-level-} binds `combineSE`
statExpr body
-statExpr (StgCase expr lve lva bndr srt alt_type alts)
+statExpr (StgCase expr _ _ _ _ _ alts)
= statExpr expr `combineSE`
stat_alts alts `combineSE`
countOne StgCases