Make debug output controllable with a top-level "constant".

diff --git a/cλash/CLasH/Normalize.hs b/cλash/CLasH/Normalize.hs
index dc3c0c2052141045c09b53f6af5af42012a50d6d..977cc0d804197915b776c77ed43645ff39fb1005 100644 (file)
--- a/cλash/CLasH/Normalize.hs
+++ b/cλash/CLasH/Normalize.hs
@@ -968,13 +968,14 @@ normalizeExpr ::
 normalizeExpr what expr = do
       startcount <- MonadState.get tsTransformCounter 
       expr_uniqued <- genUniques expr
 normalizeExpr what expr = do
       startcount <- MonadState.get tsTransformCounter 
       expr_uniqued <- genUniques expr

+      -- Do a debug print, if requested
+      let expr_uniqued' = Utils.traceIf (normalize_debug >= NormDbgFinal) (what ++ " before normalization:\n\n" ++ showSDoc ( ppr expr_uniqued ) ++ "\n") expr_uniqued

       -- Normalize this expression
       -- Normalize this expression

-      trace (what ++ " before normalization:\n\n" ++ showSDoc ( ppr expr_uniqued ) ++ "\n") $ return ()
-      expr' <- dotransforms transforms expr_uniqued
+      expr' <- dotransforms transforms expr_uniqued'

       endcount <- MonadState.get tsTransformCounter 
       endcount <- MonadState.get tsTransformCounter 

-      trace ("\n" ++ what ++ " after normalization:\n\n" ++ showSDoc ( ppr expr')
-             ++ "\nNeeded " ++ show (endcount - startcount) ++ " transformations to normalize " ++ what) $
-       return expr'
+      -- Do a debug print, if requested
+      Utils.traceIf (normalize_debug >= NormDbgFinal)  (what ++ " after normalization:\n\n" ++ showSDoc ( ppr expr') ++ "\nNeeded " ++ show (endcount - startcount) ++ " transformations to normalize " ++ what) $
+        return expr'

 
 -- | Split a normalized expression into the argument binders, top level
 --   bindings and the result binder. This function returns an error if
 
 -- | Split a normalized expression into the argument binders, top level
 --   bindings and the result binder. This function returns an error if

diff --git a/cλash/CLasH/Normalize/NormalizeTools.hs b/cλash/CLasH/Normalize/NormalizeTools.hs
index d9d4bd34e97df38f71d247d5d9ecd5707fef4665..f6c254e431381376700ed528a88cdcd9de9c118a 100644 (file)
--- a/cλash/CLasH/Normalize/NormalizeTools.hs
+++ b/cλash/CLasH/Normalize/NormalizeTools.hs
@@ -11,7 +11,6 @@ import qualified Control.Monad as Monad
 import qualified Control.Monad.Trans.Writer as Writer
 import qualified "transformers" Control.Monad.Trans as Trans
 import qualified Data.Accessor.Monad.Trans.State as MonadState
 import qualified Control.Monad.Trans.Writer as Writer
 import qualified "transformers" Control.Monad.Trans as Trans
 import qualified Data.Accessor.Monad.Trans.State as MonadState

--- import Debug.Trace

 
 -- GHC API
 import CoreSyn
 
 -- GHC API
 import CoreSyn


@@ -19,8 +18,8 @@ import qualified Name
 import qualified Id
 import qualified CoreSubst
 import qualified Type
 import qualified Id
 import qualified CoreSubst
 import qualified Type

--- import qualified CoreUtils
--- import Outputable ( showSDoc, ppr, nest )
+import qualified CoreUtils
+import Outputable ( showSDoc, ppr, nest )

 
 -- Local imports
 import CLasH.Normalize.NormalizeTypes
 
 -- Local imports
 import CLasH.Normalize.NormalizeTypes


@@ -32,29 +31,45 @@ import qualified CLasH.VHDL.VHDLTools as VHDLTools
 
 -- Apply the given transformation to all expressions in the given expression,
 -- including the expression itself.
 
 -- Apply the given transformation to all expressions in the given expression,
 -- including the expression itself.

-everywhere :: (String, Transform) -> Transform
+everywhere :: Transform -> Transform

 everywhere trans = applyboth (subeverywhere (everywhere trans)) trans
 
 everywhere trans = applyboth (subeverywhere (everywhere trans)) trans
 

+data NormDbgLevel = 
+    NormDbgNone         -- ^ No debugging
+  | NormDbgFinal        -- ^ Print functions before / after normalization
+  | NormDbgApplied      -- ^ Print expressions before / after applying transformations
+  | NormDbgAll          -- ^ Print expressions when a transformation does not apply
+  deriving (Eq, Ord)
+normalize_debug = NormDbgFinal
+
+-- Applies a transform, optionally showing some debug output.
+apply :: (String, Transform) -> Transform
+apply (name, trans) ctx expr =  do
+    -- Apply the transformation and find out if it changed anything
+    (expr', any_changed) <- Writer.listen $ trans ctx expr
+    let changed = Monoid.getAny any_changed
+    -- If it changed, increase the transformation counter 
+    Monad.when changed $ Trans.lift (MonadState.modify tsTransformCounter (+1))
+    -- Prepare some debug strings
+    let before = showSDoc (nest 4 $ ppr expr) ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr) ++ "\n"
+    let context = "Context: " ++ show ctx ++ "\n"
+    let after  = showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n"
+    traceIf (normalize_debug >= NormDbgApplied && changed) ("Changes when applying transform " ++ name ++ " to:\n" ++ before ++ context ++ "Result:\n" ++ after) $ 
+     traceIf (normalize_debug >= NormDbgAll && not changed) ("No changes when applying transform " ++ name ++ " to:\n" ++ before  ++ context) $
+     return expr'
+

 -- Apply the first transformation, followed by the second transformation, and
 -- keep applying both for as long as expression still changes.
 -- Apply the first transformation, followed by the second transformation, and
 -- keep applying both for as long as expression still changes.

-applyboth :: Transform -> (String, Transform) -> Transform
-applyboth first (name, second) context expr = do
+applyboth :: Transform -> Transform -> Transform
+applyboth first second context expr = do

   -- Apply the first
   expr' <- first context expr
   -- Apply the second
   (expr'', changed) <- Writer.listen $ second context expr'
   -- Apply the first
   expr' <- first context expr
   -- Apply the second
   (expr'', changed) <- Writer.listen $ second context expr'

-  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 
+  if Monoid.getAny $ changed

     then
     then

-     -- 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" ) $
-      do
-        Trans.lift $ MonadState.modify tsTransformCounter (+1)
-        applyboth first (name, second) context expr'' 
+      applyboth first second context expr'' 

     else 
     else 

-      -- trace ("No changes") $

       return expr''
 
 -- Apply the given transformation to all direct subexpressions (only), not the
       return expr''
 
 -- Apply the given transformation to all direct subexpressions (only), not the


@@ -107,7 +122,7 @@ subeverywhere trans c expr = error $ "\nNormalizeTools.subeverywhere: Unsupporte
 -- Runs each of the transforms repeatedly inside the State monad.
 dotransforms :: [(String, Transform)] -> CoreExpr -> TranslatorSession CoreExpr
 dotransforms transs expr = do
 -- Runs each of the transforms repeatedly inside the State monad.
 dotransforms :: [(String, Transform)] -> CoreExpr -> TranslatorSession CoreExpr
 dotransforms transs expr = do

-  (expr', changed) <- Writer.runWriterT $ Monad.foldM (\e trans -> everywhere trans [] e) expr transs
+  (expr', changed) <- Writer.runWriterT $ Monad.foldM (\e trans -> everywhere (apply trans) [] e) expr transs

   if Monoid.getAny changed then dotransforms transs expr' else return expr'
 
 -- Inline all let bindings that satisfy the given condition
   if Monoid.getAny changed then dotransforms transs expr' else return expr'
 
 -- Inline all let bindings that satisfy the given condition