From 0223b461a043e42d3fc5442904b73ce0bd537472 Mon Sep 17 00:00:00 2001
From: Matthijs Kooijman <matthijs@stdin.nl>
Date: Wed, 31 Mar 2010 14:17:37 +0200
Subject: [PATCH] Keep (and show) a count of applied transformations.

---
 "c\316\273ash/CLasH/Normalize/NormalizeTools.hs"   | 3 ++-
 "c\316\273ash/CLasH/Translator.hs"                 | 9 ++++++---
 "c\316\273ash/CLasH/Translator/TranslatorTypes.hs" | 1 +
 3 files changed, 9 insertions(+), 4 deletions(-)

diff --git "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs"
index e01b7b7..803fd95 100644
--- "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs"
+++ "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs"
@@ -45,10 +45,11 @@ applyboth first (name, second) context expr = do
   if Monoid.getAny $
         -- trace ("Trying to apply transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n")
         changed 
-    then 
+    then do
      -- trace ("Applying transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n"
      --        ++ "Context: " ++ show context ++ "\n"
      --        ++ "Result of applying " ++ name ++ ":\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $
+      Trans.lift $ MonadState.modify tsTransformCounter (+1)
       applyboth first (name, second) context expr'' 
     else 
       -- trace ("No changes") $
diff --git "a/c\316\273ash/CLasH/Translator.hs" "b/c\316\273ash/CLasH/Translator.hs"
index 79bd8d2..a9bb9fa 100644
--- "a/c\316\273ash/CLasH/Translator.hs"
+++ "b/c\316\273ash/CLasH/Translator.hs"
@@ -94,7 +94,7 @@ moduleToVHDL ::
   -> [EntitySpec]             -- ^ The entities to generate
   -> IO [(AST.VHDLId, AST.DesignFile)]
 moduleToVHDL env cores specs = do
-  vhdl <- runTranslatorSession env $ do
+  (vhdl, count) <- runTranslatorSession env $ do
     let all_bindings = concatMap (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores
     -- Store the bindings we loaded
     tsBindings %= Map.fromList all_bindings
@@ -102,10 +102,13 @@ moduleToVHDL env cores specs = do
     tsInitStates %= Map.fromList all_initstates
     test_binds <- catMaybesM $ Monad.mapM mkTest specs
     let topbinds = Maybe.catMaybes $ map (\(top, _, _) -> top) specs
-    case topbinds of
+    vhdl <- case topbinds of
       []  -> error "Could not find top entity requested"
       tops -> createDesignFiles (tops ++ test_binds)
+    count <- get tsTransformCounter 
+    return (vhdl, count)
   mapM_ (putStr . render . Ppr.ppr . snd) vhdl
+  putStr $ "Total number of transformations applied: " ++ (show count) ++ "\n"
   return vhdl
   where
     mkTest :: EntitySpec -> TranslatorSession (Maybe CoreSyn.CoreBndr)
@@ -127,7 +130,7 @@ runTranslatorSession env session = do
   -- a unique supply anywhere.
   uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
   let init_typestate = TypeState builtin_types [] Map.empty Map.empty env
-  let init_state = TranslatorState uniqSupply init_typestate Map.empty Map.empty 0 Map.empty Map.empty Map.empty
+  let init_state = TranslatorState uniqSupply init_typestate Map.empty Map.empty 0 Map.empty Map.empty Map.empty 0
   return $ State.evalState session init_state
 
 -- | Prepares the directory for writing VHDL files. This means creating the
diff --git "a/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" "b/c\316\273ash/CLasH/Translator/TranslatorTypes.hs"
index d840256..eabb004 100644
--- "a/c\316\273ash/CLasH/Translator/TranslatorTypes.hs"
+++ "b/c\316\273ash/CLasH/Translator/TranslatorTypes.hs"
@@ -93,6 +93,7 @@ data TranslatorState = TranslatorState {
   , tsEntities_ :: Map.Map CoreSyn.CoreBndr Entity
   , tsArchitectures_ :: Map.Map CoreSyn.CoreBndr (Architecture, [CoreSyn.CoreBndr])
   , tsInitStates_ :: Map.Map CoreSyn.CoreBndr CoreSyn.CoreBndr
+  , tsTransformCounter_ :: Int -- ^ How many transformations were applied?
 }
 
 -- Derive accessors
-- 
2.30.2