[make Grin.SSimplify collect stats, use it with the transformGrin wrapper to automatically iterate
John Meacham <john@repetae.net>**20070602095027] hunk ./Grin/SSimplify.hs 11
+import qualified Stats
+import Stats(mtick)
hunk ./Grin/SSimplify.hs 32
-newtype S a = S (RWS SEnv () SState a)
+newtype S a = S (RWS SEnv Stats.Stat SState a)
hunk ./Grin/SSimplify.hs 35
+instance Stats.MonadStats S where
+    mtickStat s = S (tell s)
+    mticks' n a = S (tell $ Stats.singleStat n a)
+
hunk ./Grin/SSimplify.hs 49
-    let (fs,_,_) = runRWS fun mempty SState { usedVars = mempty }
+    let (fs,_,stats) = runRWS fun mempty SState { usedVars = mempty }
hunk ./Grin/SSimplify.hs 51
-    return grin { grinFunctions = fs }
+    return grin { grinFunctions = fs, grinStats = grinStats grin `mappend` stats }
hunk ./Grin/SSimplify.hs 70
-    f b (Fetch (Const x)) = return $ Just (b,Return [x])
+    f b (Fetch (Const x)) = do
+        mtick "Grin.Simplify.fetch-const"
+        return $ Just (b,Return [x])
hunk ./Grin/SSimplify.hs 88
-    f (Fetch (Const x)) rs = f (Return [x]) rs
-    f (Store x) rs | valIsNF x = f (Return [Const x]) rs
-    f (App a [Const n] _) rs | a == funcEval = f (Return [n]) rs
-    f (Error s t) rs@(_:_) = let (_,_,b) = last rs in f (Error s (getType b)) []
+    f (Fetch (Const x)) rs = do
+        mtick "Grin.Simplify.fetch-const"
+        f (Return [x]) rs
+    f (Store x) rs | valIsNF x = do
+        mtick "Grin.Simplify.store-normalform"
+        f (Return [Const x]) rs
+    f (App a [Const n] _) rs | a == funcEval = do
+        mtick "Grin.Simplify.eval-const"
+        f (Return [n]) rs
+    f (Error s t) rs@(_:_) = do
+        mtick "Grin.Simplify.error-discard"
+        let (_,_,b) = last rs
+        f (Error s (getType b)) []
hunk ./Grin/SSimplify.hs 112
-    f (Return [v@Const {}]) ((senv,[Var vn _],b):rs) = fbind vn v senv b rs
-    f (Return [v@Var {}]) ((senv,[Var vn _],b):rs) = fbind vn v senv b rs
-    f a@(Return [NodeC t xs]) ((senv,[NodeC t' ys],b):rs) | t == t' = dtup xs ys senv b rs
-    f (Return []) ((senv,[],b):rs) = dtup [] [] senv b rs
-    f a@(Return (xs@(_:_:_))) ((senv,ys,b):rs) = dtup xs ys senv b rs
+    f (Return [v@Const {}]) ((senv,[Var vn _],b):rs) = do
+        mtick "Grin.Simplify.Subst.const"
+        fbind vn v senv b rs
+    f (Return [v@Var {}]) ((senv,[Var vn _],b):rs) = do
+        mtick "Grin.Simplify.Subst.var"
+        fbind vn v senv b rs
+    f a@(Return [NodeC t xs]) ((senv,[NodeC t' ys],b):rs) | t == t' = do
+        mtick "Grin.Simplify.Assign.node-node"
+        dtup xs ys senv b rs
+    f (Return []) ((senv,[],b):rs) = do
+        mtick "Grin.Simplify.Assign.unit-unit"
+        dtup [] [] senv b rs
+    f a@(Return (xs@(_:_:_))) ((senv,ys,b):rs) = do
+        mtick "Grin.Simplify.Assign.tuple-tuple"
+        dtup xs ys senv b rs
hunk ./Main.hs 54
-import Grin.Whiz
hunk ./Main.hs 670
+simplifyParms = transformParms {
+    transformDumpProgress = True,
+    transformCategory = "Simplify",
+    transformPass = "Grin",
+    transformOperation = Grin.SSimplify.simplify,
+    transformIterate = IterateDone
+    }
+
hunk ./Main.hs 687
-    x <- Grin.SSimplify.simplify x
+    x <- transformGrin simplifyParms x
hunk ./Main.hs 691
-            grin <- return $ normalizeGrin grin
+            grin <- transformGrin simplifyParms grin
hunk ./Main.hs 738
-    x <- return $ normalizeGrin x
+    x <- transformGrin simplifyParms x