X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplStg%2FStgStats.lhs;h=824c112a1ceedc30ca55edef7e9b70832547c0cc;hb=32c62212b35b2b631f3753d432b508de5c79c783;hp=2b16fc06c9a462610e6236dc6ebe3d93bfb9ba44;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplStg/StgStats.lhs b/ghc/compiler/simplStg/StgStats.lhs
index 2b16fc0..824c112 100644
--- a/ghc/compiler/simplStg/StgStats.lhs
+++ b/ghc/compiler/simplStg/StgStats.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[StgStats]{Gathers statistical information about programs}
 
@@ -21,32 +21,31 @@ The program gather statistics about
 \end{enumerate}
 
 \begin{code}
-#include "HsVersions.h"
-
 module StgStats ( showStgStats ) where
 
-import StgSyn
+#include "HsVersions.h"
 
-import FiniteMap
+import StgSyn
 
-import Util
+import FiniteMap	( emptyFM, plusFM_C, unitFM, fmToList, FiniteMap )
+import Id (Id)
 \end{code}
 
 \begin{code}
 data CounterType
-  = AlgCases
-  | PrimCases
-  | LetNoEscapes
-  | NonUpdatableLets
-  | UpdatableLets
+  = Literals
   | Applications
+  | ConstructorApps
   | PrimitiveApps
+  | LetNoEscapes
+  | AlgCases
+  | PrimCases
   | FreeVariables
-  | Closures	-- does not include lets bound to constructors
---| UpdatableTopLevelDefs
---| NonUpdatableTopLevelDefs
-  | Constructors
-  deriving (Eq, Ord, Text)
+  | ConstructorBinds Bool{-True<=>top-level-}
+  | ReEntrantBinds   Bool{-ditto-}
+  | SingleEntryBinds Bool{-ditto-}
+  | UpdatableBinds   Bool{-ditto-}
+  deriving (Eq, Ord)
 
 type Count	= Int
 type StatEnv	= FiniteMap CounterType Count
@@ -63,10 +62,10 @@ combineSEs :: [StatEnv] -> StatEnv
 combineSEs = foldr combineSE emptySE
 
 countOne :: CounterType -> StatEnv
-countOne c = singletonFM c 1
+countOne c = unitFM c 1
 
 countN :: CounterType -> Int -> StatEnv
-countN = singletonFM
+countN = unitFM
 \end{code}
 
 %************************************************************************
@@ -76,24 +75,35 @@ countN = singletonFM
 %************************************************************************
 
 \begin{code}
-showStgStats :: PlainStgProgram -> String
-showStgStats prog = concat (map showc (fmToList (gatherStgStats prog)))
+showStgStats :: [StgBinding] -> String
+
+showStgStats prog
+  = "STG Statistics:\n\n"
+    ++ concat (map showc (fmToList (gatherStgStats prog)))
   where
-    showc (AlgCases,n)         = "AlgCases               " ++ show n ++ "\n"
-    showc (PrimCases,n)        = "PrimCases              " ++ show n ++ "\n"
-    showc (LetNoEscapes,n)     = "LetNoEscapes           " ++ show n ++ "\n"
-    showc (NonUpdatableLets,n) = "NonUpdatableLets       " ++ show n ++ "\n"
-    showc (UpdatableLets,n)    = "UpdatableLets          " ++ show n ++ "\n"
-    showc (Applications,n)     = "Applications           " ++ show n ++ "\n"
-    showc (PrimitiveApps,n)    = "PrimitiveApps          " ++ show n ++ "\n"
-    showc (Closures,n)         = "Closures               " ++ show n ++ "\n"
-    showc (FreeVariables,n)    = "Free Vars in Closures  " ++ show n ++ "\n"
-    showc (Constructors,n)     = "Constructors           " ++ show n ++ "\n"
-
-gatherStgStats :: PlainStgProgram -> StatEnv
-
-gatherStgStats binds 
-  = combineSEs (map statBinding binds)
+    showc (x,n) = (showString (s x) . shows n) "\n"
+
+    s Literals		      = "Literals                   "
+    s Applications	      = "Applications               "
+    s ConstructorApps	      = "ConstructorApps            "
+    s PrimitiveApps	      = "PrimitiveApps              "
+    s LetNoEscapes	      = "LetNoEscapes               "
+    s AlgCases		      = "AlgCases                   "
+    s PrimCases		      = "PrimCases                  "
+    s FreeVariables	      = "FreeVariables              "
+    s (ConstructorBinds True) = "ConstructorBinds_Top       "
+    s (ReEntrantBinds True)   = "ReEntrantBinds_Top         "
+    s (SingleEntryBinds True) = "SingleEntryBinds_Top       "
+    s (UpdatableBinds True)   = "UpdatableBinds_Top         "
+    s (ConstructorBinds _)    = "ConstructorBinds_Nested    "
+    s (ReEntrantBinds _)      = "ReEntrantBindsBinds_Nested "
+    s (SingleEntryBinds _)    = "SingleEntryBinds_Nested    "
+    s (UpdatableBinds _)      = "UpdatableBinds_Nested      "
+
+gatherStgStats :: [StgBinding] -> StatEnv
+
+gatherStgStats binds
+  = combineSEs (map (statBinding True{-top-level-}) binds)
 \end{code}
 
 %************************************************************************
@@ -103,28 +113,30 @@ gatherStgStats binds
 %************************************************************************
 
 \begin{code}
-statBinding :: PlainStgBinding -> StatEnv
+statBinding :: Bool -- True <=> top-level; False <=> nested
+	    -> StgBinding
+	    -> StatEnv
 
-statBinding (StgNonRec b rhs)
-  = statRhs (b, rhs)
+statBinding top (StgNonRec _srt b rhs)
+  = statRhs top (b, rhs)
 
-statBinding (StgRec pairs)
-  = combineSEs (map statRhs pairs)
+statBinding top (StgRec _srt pairs)
+  = combineSEs (map (statRhs top) pairs)
 
-statRhs :: (Id, PlainStgRhs) -> StatEnv
+statRhs :: Bool -> (Id, StgRhs) -> StatEnv
 
-statRhs (b, StgRhsCon cc con args)
-  = countOne Constructors		`combineSE` 
-    countOne NonUpdatableLets
+statRhs top (b, StgRhsCon cc con args)
+  = countOne (ConstructorBinds top)
 
-statRhs (b, StgRhsClosure cc bi fv u args body)
-  = statExpr body			`combineSE` 
+statRhs top (b, StgRhsClosure cc bi fv u args body)
+  = statExpr body			`combineSE`
     countN FreeVariables (length fv)	`combineSE`
-    countOne Closures			`combineSE` 
-    (case u of
-       Updatable -> countOne UpdatableLets
-       _         -> countOne NonUpdatableLets)
-
+    countOne (
+      case u of
+	ReEntrant   -> ReEntrantBinds   top
+	Updatable   -> UpdatableBinds   top
+	SingleEntry -> SingleEntryBinds top
+    )
 \end{code}
 
 %************************************************************************
@@ -133,56 +145,42 @@ statRhs (b, StgRhsClosure cc bi fv u args body)
 %*									*
 %************************************************************************
 
-\begin{code}    
-statExpr :: PlainStgExpr -> StatEnv
-
-statExpr (StgApp _ [] lvs) 
-  = emptySE
-statExpr (StgApp _ _ lvs) 
-  = countOne Applications
-
-statExpr (StgConApp con as lvs)
-  = countOne Constructors
-
-statExpr (StgPrimApp op as lvs)
-  = countOne PrimitiveApps
+\begin{code}
+statExpr :: StgExpr -> StatEnv
 
-statExpr (StgSCC ty l e)
-  = statExpr e
+statExpr (StgApp _ _)	  = countOne Applications
+statExpr (StgLit _)	  = countOne Literals
+statExpr (StgConApp _ _)  = countOne ConstructorApps
+statExpr (StgOpApp _ _ _) = countOne PrimitiveApps
+statExpr (StgSCC l e) 	  = statExpr e
 
 statExpr (StgLetNoEscape lvs_whole lvs_rhss binds body)
-  = statBinding binds	`combineSE`
-    statExpr body	`combineSE` 
+  = statBinding False{-not top-level-} binds	`combineSE`
+    statExpr body				`combineSE`
     countOne LetNoEscapes
 
 statExpr (StgLet binds body)
-  = statBinding binds	`combineSE` 
+  = statBinding False{-not top-level-} binds	`combineSE`
     statExpr body
 
-statExpr (StgCase expr lve lva uniq alts)
+statExpr (StgCase expr lve lva bndr srt alts)
   = statExpr expr	`combineSE`
     stat_alts alts
     where
       stat_alts (StgAlgAlts ty alts def)
-	= combineSEs (map stat_alg_alt alts)	`combineSE` 
-	  stat_deflt def			`combineSE`
+	= combineSEs (map statExpr [ e | (_,_,_,e) <- alts ])
+					`combineSE`
+	  stat_deflt def		`combineSE`
 	  countOne AlgCases
-	where
-	  stat_alg_alt (id, bs, use_mask, e)
-	    = statExpr e
 
       stat_alts (StgPrimAlts ty alts def)
-	= combineSEs (map stat_prim_alt alts) 	`combineSE`
-	  stat_deflt def			`combineSE`
+	= combineSEs (map statExpr [ e | (_,e) <- alts ])
+					`combineSE`
+	  stat_deflt def		`combineSE`
 	  countOne PrimCases
-	where
-	  stat_prim_alt (l, e)
-	    = statExpr e
 
-      stat_deflt StgNoDefault
-	= emptySE
+      stat_deflt StgNoDefault = emptySE
 
-      stat_deflt (StgBindDefault b u expr)
-	= statExpr expr	
+      stat_deflt (StgBindDefault expr) = statExpr expr
 \end{code}