Continue refactoring the core-to-core pipeline

This patch mainly concerns the plumbing for running
the passes and printing intermediate output

diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index ee6541e..62fe897 100644 (file)
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -36,7 +36,6 @@ import BasicTypes
 import StaticFlags
 import ListSetOps
 import PrelNames
 import StaticFlags
 import ListSetOps
 import PrelNames

-import DynFlags

 import Outputable
 import FastString
 import Util
 import Outputable
 import FastString
 import Util

@@ -96,29 +95,11 @@ find an occurence of an Id, we fetch it from the in-scope set.
 
 
 \begin{code}
 
 
 \begin{code}

-lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
-
-lintCoreBindings dflags _whoDunnit _binds
-  | not (dopt Opt_DoCoreLinting dflags)
-  = return ()
-
-lintCoreBindings dflags whoDunnit binds
-  | isEmptyBag errs
-  = do { showPass dflags ("Core Linted result of " ++ whoDunnit)
-       ; unless (isEmptyBag warns || opt_NoDebugOutput) $ printDump $
-         (banner "warnings" $$ displayMessageBag warns)
-       ; return () }
-
-  | otherwise
-  = do { printDump (vcat [ banner "errors", displayMessageBag errs
-                        , ptext (sLit "*** Offending Program ***")
-                        , pprCoreBindings binds
-                        , ptext (sLit "*** End of Offense ***") ])
-
-       ; ghcExit dflags 1 }
+lintCoreBindings :: [CoreBind] -> (Bag Message, Bag Message)
+--   Returns (warnings, errors)
+lintCoreBindings binds
+  = initL (lint_binds binds)

   where
   where

-    (warns, errs) = initL (lint_binds binds)
-

        -- Put all the top-level binders in scope at the start
        -- This is because transformation rules can bring something
        -- into use 'unexpectedly'
        -- Put all the top-level binders in scope at the start
        -- This is because transformation rules can bring something
        -- into use 'unexpectedly'

@@ -128,13 +109,6 @@ lintCoreBindings dflags whoDunnit binds
 
     lint_bind (Rec prs)                = mapM_ (lintSingleBinding TopLevel Recursive) prs
     lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)
 
     lint_bind (Rec prs)                = mapM_ (lintSingleBinding TopLevel Recursive) prs
     lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)

-
-    banner string = ptext (sLit "*** Core Lint")      <+> text string 
-                    <+> ptext (sLit ": in result of") <+> text whoDunnit 
-                    <+> ptext (sLit "***")
-
-displayMessageBag :: Bag Message -> SDoc
-displayMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -154,7 +128,7 @@ lintUnfolding :: SrcLoc
 
 lintUnfolding locn vars expr
   | isEmptyBag errs = Nothing
 
 lintUnfolding locn vars expr
   | isEmptyBag errs = Nothing

-  | otherwise       = Just (displayMessageBag errs)
+  | otherwise       = Just (pprMessageBag errs)

   where
     (_warns, errs) = initL (addLoc (ImportedUnfolding locn) $
                             addInScopeVars vars                   $
   where
     (_warns, errs) = initL (addLoc (ImportedUnfolding locn) $
                             addInScopeVars vars                   $

diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index 738bf82..5616803 100644 (file)
--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -15,7 +15,7 @@ import PrelNames      ( lazyIdKey, hasKey )
 import CoreUtils
 import CoreArity
 import CoreFVs
 import CoreUtils
 import CoreArity
 import CoreFVs

-import CoreMonad       ( endPass )
+import CoreMonad       ( endPass, CoreToDo(..) )

 import CoreSyn
 import Type
 import Coercion
 import CoreSyn
 import Type
 import Coercion

@@ -147,7 +147,7 @@ corePrepPgm dflags binds data_tycons = do
                       floats2 <- corePrepTopBinds implicit_binds
                       return (deFloatTop (floats1 `appendFloats` floats2))
 
                       floats2 <- corePrepTopBinds implicit_binds
                       return (deFloatTop (floats1 `appendFloats` floats2))
 

-    endPass dflags "CorePrep" Opt_D_dump_prep binds_out []
+    endPass dflags CorePrep binds_out []

     return binds_out
 
 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
     return binds_out
 
 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr

diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index 3b30dea..64fff0d 100644 (file)
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -28,7 +28,7 @@ import Module
 import RdrName
 import NameSet
 import Rules
 import RdrName
 import NameSet
 import Rules

-import CoreMonad       ( endPass )
+import CoreMonad       ( endPass, CoreToDo(..) )

 import ErrUtils
 import Outputable
 import SrcLoc
 import ErrUtils
 import Outputable
 import SrcLoc

@@ -114,7 +114,7 @@ deSugar hsc_env
        -- things into the in-scope set before simplifying; so we get no unfolding for F#!
 
        -- Lint result if necessary
        -- things into the in-scope set before simplifying; so we get no unfolding for F#!
 
        -- Lint result if necessary

-       ; endPass dflags "Desugar" Opt_D_dump_ds ds_binds ds_rules
+       ; endPass dflags CoreDesugar ds_binds ds_rules

 
        -- Dump output
        ; doIfSet (dopt Opt_D_dump_ds dflags) 
 
        -- Dump output
        ; doIfSet (dopt Opt_D_dump_ds dflags) 

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index d64e98e..f1328e0 100644 (file)
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -5,7 +5,7 @@
 
 \begin{code}
 module ErrUtils (
 
 \begin{code}
 module ErrUtils (

-       Message, mkLocMessage, printError,
+       Message, mkLocMessage, printError, pprMessageBag,

        Severity(..),
 
        ErrMsg, WarnMsg,
        Severity(..),
 
        ErrMsg, WarnMsg,

@@ -18,7 +18,7 @@ module ErrUtils (
 
        ghcExit,
        doIfSet, doIfSet_dyn, 
 
        ghcExit,
        doIfSet, doIfSet_dyn, 

-       dumpIfSet, dumpIf_core, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or,
+       dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_or,

         mkDumpDoc, dumpSDoc,
 
        --  * Messages during compilation
         mkDumpDoc, dumpSDoc,
 
        --  * Messages during compilation

@@ -49,6 +49,9 @@ import System.IO
 
 type Message = SDoc
 
 
 type Message = SDoc
 

+pprMessageBag :: Bag Message -> SDoc
+pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
+

 data Severity
   = SevInfo
   | SevWarning
 data Severity
   = SevInfo
   | SevWarning

@@ -202,19 +205,6 @@ dumpIfSet flag hdr doc
   | not flag   = return ()
   | otherwise  = printDump (mkDumpDoc hdr doc)
 
   | not flag   = return ()
   | otherwise  = printDump (mkDumpDoc hdr doc)
 

-dumpIf_core :: Bool -> DynFlags -> DynFlag -> String -> SDoc -> IO ()
-dumpIf_core cond dflags dflag hdr doc
-  | cond
-    || verbosity dflags >= 4
-    || dopt Opt_D_verbose_core2core dflags
-  = dumpSDoc dflags dflag hdr doc
-
-  | otherwise = return ()
-
-dumpIfSet_core :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
-dumpIfSet_core dflags flag hdr doc
-  = dumpIf_core (dopt flag dflags) dflags flag hdr doc
-

 dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
 dumpIfSet_dyn dflags flag hdr doc
   | dopt flag dflags || verbosity dflags >= 4 
 dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
 dumpIfSet_dyn dflags flag hdr doc
   | dopt flag dflags || verbosity dflags >= 4 

diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 4c01bc5..98ab1d9 100644 (file)
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -18,6 +18,7 @@ import CoreFVs
 import CoreTidy
 import CoreMonad
 import CoreUtils
 import CoreTidy
 import CoreMonad
 import CoreUtils

+import Rules

 import CoreArity       ( exprArity, exprBotStrictness_maybe )
 import Class           ( classSelIds )
 import VarEnv
 import CoreArity       ( exprArity, exprBotStrictness_maybe )
 import Class           ( classSelIds )
 import VarEnv

@@ -38,11 +39,11 @@ import TyCon
 import Module
 import HscTypes
 import Maybes
 import Module
 import HscTypes
 import Maybes

-import ErrUtils

 import UniqSupply
 import Outputable
 import FastBool hiding ( fastOr )
 import Util
 import UniqSupply
 import Outputable
 import FastBool hiding ( fastOr )
 import Util

+import FastString

 
 import Data.List       ( sortBy )
 import Data.IORef      ( IORef, readIORef, writeIORef )
 
 import Data.List       ( sortBy )
 import Data.IORef      ( IORef, readIORef, writeIORef )

@@ -133,7 +134,7 @@ mkBootModDetails :: HscEnv -> [AvailInfo] -> NameEnv TyThing
                  -> [Instance] -> [FamInstEnv.FamInst] -> IO ModDetails
 mkBootModDetails hsc_env exports type_env insts fam_insts
   = do { let dflags = hsc_dflags hsc_env 
                  -> [Instance] -> [FamInstEnv.FamInst] -> IO ModDetails
 mkBootModDetails hsc_env exports type_env insts fam_insts
   = do { let dflags = hsc_dflags hsc_env 

-       ; showPass dflags "Tidy [hoot] type env"
+       ; showPass dflags CoreTidy

 
        ; let { insts'     = tidyInstances globaliseAndTidyId insts
              ; dfun_ids   = map instanceDFunId insts'
 
        ; let { insts'     = tidyInstances globaliseAndTidyId insts
              ; dfun_ids   = map instanceDFunId insts'

@@ -301,7 +302,7 @@ tidyProgram hsc_env  (ModGuts { mg_module = mod, mg_exports = exports,
              ; expose_all = dopt Opt_ExposeAllUnfoldings  dflags
              ; th         = dopt Opt_TemplateHaskell      dflags
               }
              ; expose_all = dopt Opt_ExposeAllUnfoldings  dflags
              ; th         = dopt Opt_TemplateHaskell      dflags
               }

-       ; showPass dflags "Tidy Core"
+       ; showPass dflags CoreTidy

 
        ; let { implicit_binds = getImplicitBinds type_env }
 
 
        ; let { implicit_binds = getImplicitBinds type_env }
 

@@ -342,7 +343,15 @@ tidyProgram hsc_env  (ModGuts { mg_module = mod, mg_exports = exports,
              ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
              }
 
              ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
              }
 

-       ; endPass dflags "Tidy Core" Opt_D_dump_simpl all_tidy_binds tidy_rules
+       ; endPass dflags CoreTidy all_tidy_binds tidy_rules
+
+         -- If the endPass didn't print the rules, but ddump-rules is on, print now
+       ; dumpIfSet (dopt Opt_D_dump_rules dflags 
+                     && (not (dopt Opt_D_dump_simpl dflags))) 
+                   CoreTidy
+                    (ptext (sLit "rules"))
+                    (pprRulesForUser tidy_rules)
+

         ; let dir_imp_mods = moduleEnvKeys dir_imps
 
        ; return (CgGuts { cg_module   = mod, 
         ; let dir_imp_mods = moduleEnvKeys dir_imps
 
        ; return (CgGuts { cg_module   = mod, 

diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs
index ef8c428..f9ff5e7 100644 (file)
--- a/compiler/simplCore/CoreMonad.lhs
+++ b/compiler/simplCore/CoreMonad.lhs
@@ -36,13 +36,13 @@ module CoreMonad (
     getAnnotations, getFirstAnnotations,
     
     -- ** Debug output
     getAnnotations, getFirstAnnotations,
     
     -- ** Debug output

-    endPass, endPassIf, endIteration,
+    showPass, endPass, endIteration, dumpIfSet,

 
     -- ** Screen output
     putMsg, putMsgS, errorMsg, errorMsgS, 
     fatalErrorMsg, fatalErrorMsgS, 
     debugTraceMsg, debugTraceMsgS,
 
     -- ** Screen output
     putMsg, putMsgS, errorMsg, errorMsgS, 
     fatalErrorMsg, fatalErrorMsgS, 
     debugTraceMsg, debugTraceMsgS,

-    dumpIfSet_dyn,
+    dumpIfSet_dyn, 

 
 #ifdef GHCI
     -- * Getting 'Name's
 
 #ifdef GHCI
     -- * Getting 'Name's

@@ -75,6 +75,7 @@ import TcRnMonad        ( TcM, initTc )
 import Outputable
 import FastString
 import qualified ErrUtils as Err
 import Outputable
 import FastString
 import qualified ErrUtils as Err

+import Bag

 import Maybes
 import UniqSupply
 import LazyUniqFM       ( UniqFM, mapUFM, filterUFM )
 import Maybes
 import UniqSupply
 import LazyUniqFM       ( UniqFM, mapUFM, filterUFM )

@@ -106,35 +107,80 @@ be, and it makes a conveneint place.  place for them.  They print out
 stuff before and after core passes, and do Core Lint when necessary.
 
 \begin{code}
 stuff before and after core passes, and do Core Lint when necessary.
 
 \begin{code}

-endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
-endPass = dumpAndLint Err.dumpIfSet_core
+showPass :: DynFlags -> CoreToDo -> IO ()
+showPass dflags pass = Err.showPass dflags (showSDoc (ppr pass))

 
 

-endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
-endPassIf cond = dumpAndLint (Err.dumpIf_core cond)
+endPass :: DynFlags -> CoreToDo -> [CoreBind] -> [CoreRule] -> IO ()
+endPass dflags pass = dumpAndLint dflags True pass empty (coreDumpFlag pass)

 
 -- Same as endPass but doesn't dump Core even with -dverbose-core2core
 
 -- Same as endPass but doesn't dump Core even with -dverbose-core2core

-endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
-endIteration = dumpAndLint Err.dumpIfSet_dyn
+endIteration :: DynFlags -> CoreToDo -> Int -> [CoreBind] -> [CoreRule] -> IO ()
+endIteration dflags pass n
+  = dumpAndLint dflags False pass (ptext (sLit "iteration=") <> int n)
+                (Just Opt_D_dump_simpl_iterations)

 
 

-dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ())
-            -> DynFlags -> String -> DynFlag 
+dumpIfSet :: Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
+dumpIfSet dump_me pass extra_info doc
+  = Err.dumpIfSet dump_me (showSDoc (ppr pass <+> extra_info)) doc
+
+dumpAndLint :: DynFlags -> Bool -> CoreToDo -> SDoc -> Maybe DynFlag

             -> [CoreBind] -> [CoreRule] -> IO ()
             -> [CoreBind] -> [CoreRule] -> IO ()

-dumpAndLint dump dflags pass_name dump_flag binds rules
+-- The "show_all" parameter says to print dump if -dverbose-core2core is on
+dumpAndLint dflags show_all pass extra_info mb_dump_flag binds rules

   = do {  -- Report result size if required
          -- This has the side effect of forcing the intermediate to be evaluated
        ; Err.debugTraceMsg dflags 2 $
                (text "    Result size =" <+> int (coreBindsSize binds))
 
        -- Report verbosely, if required
   = do {  -- Report result size if required
          -- This has the side effect of forcing the intermediate to be evaluated
        ; Err.debugTraceMsg dflags 2 $
                (text "    Result size =" <+> int (coreBindsSize binds))
 
        -- Report verbosely, if required

-       ; dump dflags dump_flag pass_name
-              (pprCoreBindings binds $$ ppUnless (null rules) pp_rules)
+       ; let pass_name = showSDoc (ppr pass <+> extra_info)
+             dump_doc  = pprCoreBindings binds 
+                         $$ ppUnless (null rules) pp_rules
+
+       ; case mb_dump_flag of
+            Nothing        -> return ()
+            Just dump_flag -> Err.dumpIfSet_dyn_or dflags dump_flags pass_name dump_doc
+               where
+                 dump_flags | show_all  = [dump_flag, Opt_D_verbose_core2core]
+                           | otherwise = [dump_flag] 

 
        -- Type check
 
        -- Type check

-       ; lintCoreBindings dflags pass_name binds }
+       ; when (dopt Opt_DoCoreLinting dflags) $
+         do { let (warns, errs) = lintCoreBindings binds
+            ; Err.showPass dflags ("Core Linted result of " ++ pass_name)
+            ; displayLintResults dflags pass warns errs binds  } }

   where
     pp_rules = vcat [ blankLine
                     , ptext (sLit "------ Local rules for imported ids --------")
                     , pprRules rules ]
   where
     pp_rules = vcat [ blankLine
                     , ptext (sLit "------ Local rules for imported ids --------")
                     , pprRules rules ]

+
+displayLintResults :: DynFlags -> CoreToDo
+                   -> Bag Err.Message -> Bag Err.Message -> [CoreBind]
+                   -> IO ()
+displayLintResults dflags pass warns errs binds
+  | not (isEmptyBag errs)
+  = do { printDump (vcat [ banner "errors", Err.pprMessageBag errs
+                        , ptext (sLit "*** Offending Program ***")
+                        , pprCoreBindings binds
+                        , ptext (sLit "*** End of Offense ***") ])
+       ; Err.ghcExit dflags 1 }
+
+  | not (isEmptyBag warns)
+  , not opt_NoDebugOutput
+  , showLintWarnings pass
+  = printDump (banner "warnings" $$ Err.pprMessageBag warns)
+
+  | otherwise = return ()
+  where
+    banner string = ptext (sLit "*** Core Lint")      <+> text string 
+                    <+> ptext (sLit ": in result of") <+> ppr pass
+                    <+> ptext (sLit "***")
+
+showLintWarnings :: CoreToDo -> Bool
+-- Disable Lint warnings on the first simplifier pass, because
+-- there may be some INLINE knots still tied, which is tiresomely noisy
+showLintWarnings (CoreDoSimplify (SimplGently {}) _ _) = False
+showLintWarnings _                                     = True

 \end{code}
 
 
 \end{code}
 
 

@@ -152,9 +198,9 @@ data CoreToDo           -- These are diff core-to-core passes,
 
   = CoreDoSimplify      -- The core-to-core simplifier.
         SimplifierMode
 
   = CoreDoSimplify      -- The core-to-core simplifier.
         SimplifierMode

-        [SimplifierSwitch]
-                        -- Each run of the simplifier can take a different
-                        -- set of simplifier-specific flags.
+       Int                    -- Max iterations
+        [SimplifierSwitch]     -- Each run of the simplifier can take a different
+                               -- set of simplifier-specific flags.

   | CoreDoFloatInwards
   | CoreDoFloatOutwards FloatOutSwitches
   | CoreLiberateCase
   | CoreDoFloatInwards
   | CoreDoFloatOutwards FloatOutSwitches
   | CoreLiberateCase

@@ -164,7 +210,6 @@ data CoreToDo           -- These are diff core-to-core passes,
   | CoreDoWorkerWrapper
   | CoreDoSpecialising
   | CoreDoSpecConstr
   | CoreDoWorkerWrapper
   | CoreDoSpecialising
   | CoreDoSpecConstr

-  | CoreDoOldStrictness

   | CoreDoGlomBinds
   | CoreCSE
   | CoreDoRuleCheck CompilerPhase String   -- Check for non-application of rules
   | CoreDoGlomBinds
   | CoreCSE
   | CoreDoRuleCheck CompilerPhase String   -- Check for non-application of rules

@@ -173,7 +218,59 @@ data CoreToDo           -- These are diff core-to-core passes,
   | CoreDoNothing                -- Useful when building up
   | CoreDoPasses [CoreToDo]      -- lists of these things
 
   | CoreDoNothing                -- Useful when building up
   | CoreDoPasses [CoreToDo]      -- lists of these things
 

+  | CoreDesugar         -- Not strictly a core-to-core pass, but produces
+                 -- Core output, and hence useful to pass to endPass
+
+  | CoreTidy
+  | CorePrep
+
+coreDumpFlag :: CoreToDo -> Maybe DynFlag
+coreDumpFlag (CoreDoSimplify {})      = Just Opt_D_dump_simpl_phases
+coreDumpFlag CoreDoFloatInwards       = Just Opt_D_verbose_core2core
+coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
+coreDumpFlag CoreLiberateCase         = Just Opt_D_verbose_core2core
+coreDumpFlag CoreDoStaticArgs        = Just Opt_D_verbose_core2core
+coreDumpFlag CoreDoStrictness        = Just Opt_D_dump_stranal
+coreDumpFlag CoreDoWorkerWrapper      = Just Opt_D_dump_worker_wrapper
+coreDumpFlag CoreDoSpecialising       = Just Opt_D_dump_spec
+coreDumpFlag CoreDoSpecConstr         = Just Opt_D_dump_spec
+coreDumpFlag CoreCSE                  = Just Opt_D_dump_cse 
+coreDumpFlag (CoreDoVectorisation {}) = Just Opt_D_dump_vect
+coreDumpFlag CoreDesugar             = Just Opt_D_dump_ds 
+coreDumpFlag CoreTidy                = Just Opt_D_dump_simpl
+coreDumpFlag CorePrep                = Just Opt_D_dump_prep
+
+coreDumpFlag CoreDoPrintCore         = Nothing
+coreDumpFlag (CoreDoRuleCheck {})    = Nothing
+coreDumpFlag CoreDoNothing           = Nothing
+coreDumpFlag CoreDoGlomBinds         = Nothing
+coreDumpFlag (CoreDoPasses {})       = Nothing
+
+instance Outputable CoreToDo where
+  ppr (CoreDoSimplify md n _)  = ptext (sLit "Simplifier") 
+                                 <+> ppr md
+                                 <+> ptext (sLit "max-iterations=") <> int n
+  ppr CoreDoFloatInwards       = ptext (sLit "Float inwards")
+  ppr (CoreDoFloatOutwards f)  = ptext (sLit "Float out") <> parens (ppr f)
+  ppr CoreLiberateCase         = ptext (sLit "Liberate case")
+  ppr CoreDoStaticArgs                = ptext (sLit "Static argument")
+  ppr CoreDoStrictness                = ptext (sLit "Demand analysis")
+  ppr CoreDoWorkerWrapper      = ptext (sLit "Worker Wrapper binds")
+  ppr CoreDoSpecialising       = ptext (sLit "Specialise")
+  ppr CoreDoSpecConstr         = ptext (sLit "SpecConstr")
+  ppr CoreCSE                  = ptext (sLit "Common sub-expression")
+  ppr (CoreDoVectorisation {}) = ptext (sLit "Vectorisation")
+  ppr CoreDesugar             = ptext (sLit "Desugar")
+  ppr CoreTidy                        = ptext (sLit "Tidy Core")
+  ppr CorePrep                        = ptext (sLit "CorePrep")
+  ppr CoreDoPrintCore          = ptext (sLit "Print core")
+  ppr (CoreDoRuleCheck {})     = ptext (sLit "Rule check")
+  ppr CoreDoGlomBinds          = ptext (sLit "Glom binds")
+  ppr CoreDoNothing            = ptext (sLit "CoreDoNothing")
+  ppr (CoreDoPasses {})        = ptext (sLit "CoreDoPasses")
+\end{code}

 
 

+\begin{code}

 data SimplifierMode             -- See comments in SimplMonad
   = SimplGently
        { sm_rules :: Bool      -- Whether RULES are enabled 
 data SimplifierMode             -- See comments in SimplMonad
   = SimplGently
        { sm_rules :: Bool      -- Whether RULES are enabled 

@@ -185,7 +282,7 @@ data SimplifierMode             -- See comments in SimplMonad
 
 instance Outputable SimplifierMode where
     ppr (SimplPhase { sm_num = n, sm_names = ss })
 
 instance Outputable SimplifierMode where
     ppr (SimplPhase { sm_num = n, sm_names = ss })

-       = int n <+> brackets (text (concat $ intersperse "," ss))
+       = ptext (sLit "Phase") <+> int n <+> brackets (text (concat $ intersperse "," ss))

     ppr (SimplGently { sm_rules = r, sm_inline = i }) 
        = ptext (sLit "gentle") <> 
            brackets (pp_flag r (sLit "rules") <> comma <>
     ppr (SimplGently { sm_rules = r, sm_inline = i }) 
        = ptext (sLit "gentle") <> 
            brackets (pp_flag r (sLit "rules") <> comma <>

@@ -194,15 +291,16 @@ instance Outputable SimplifierMode where
            pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
 
 data SimplifierSwitch
            pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
 
 data SimplifierSwitch

-  = MaxSimplifierIterations Int
-  | NoCaseOfCase
+  = NoCaseOfCase
+\end{code}
+

 
 

+\begin{code}

 data FloatOutSwitches = FloatOutSwitches {
         floatOutLambdas :: Bool,     -- ^ True <=> float lambdas to top level
         floatOutConstants :: Bool    -- ^ True <=> float constants to top level,
                                      --            even if they do not escape a lambda
     }
 data FloatOutSwitches = FloatOutSwitches {
         floatOutLambdas :: Bool,     -- ^ True <=> float lambdas to top level
         floatOutConstants :: Bool    -- ^ True <=> float constants to top level,
                                      --            even if they do not escape a lambda
     }

-

 instance Outputable FloatOutSwitches where
     ppr = pprFloatOutSwitches
 
 instance Outputable FloatOutSwitches where
     ppr = pprFloatOutSwitches
 

@@ -254,11 +352,10 @@ getCoreToDo dflags
 
     simpl_phase phase names iter
       = CoreDoPasses
 
     simpl_phase phase names iter
       = CoreDoPasses

-          [ maybe_strictness_before phase,
-            CoreDoSimplify (SimplPhase phase names) [
-              MaxSimplifierIterations iter
-            ],
-            maybe_rule_check phase
+          [ maybe_strictness_before phase
+          , CoreDoSimplify (SimplPhase phase names) 
+                           iter []
+          , maybe_rule_check phase

           ]
 
     vectorisation
           ]
 
     vectorisation

@@ -284,6 +381,7 @@ getCoreToDo dflags
         -- initial simplify: mk specialiser happy: minimum effort please
     simpl_gently = CoreDoSimplify 
                        (SimplGently { sm_rules = True, sm_inline = False })
         -- initial simplify: mk specialiser happy: minimum effort please
     simpl_gently = CoreDoSimplify 
                        (SimplGently { sm_rules = True, sm_inline = False })

+                       max_iter

                        [
                         --      Simplify "gently"
                         -- Don't inline anything till full laziness has bitten
                        [
                         --      Simplify "gently"
                         -- Don't inline anything till full laziness has bitten

@@ -295,9 +393,8 @@ getCoreToDo dflags
                         -- Similarly, don't apply any rules until after full
                         -- laziness.  Notably, list fusion can prevent floating.
 
                         -- Similarly, don't apply any rules until after full
                         -- laziness.  Notably, list fusion can prevent floating.
 

-            NoCaseOfCase,       -- Don't do case-of-case transformations.
+            NoCaseOfCase        -- Don't do case-of-case transformations.

                                 -- This makes full laziness work better
                                 -- This makes full laziness work better

-            MaxSimplifierIterations max_iter

         ]
 
     core_todo =
         ]
 
     core_todo =

diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index 8ec2d1d..4df489b 100644 (file)
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -130,57 +130,55 @@ simplifyExpr dflags expr
        }
 
 doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts
        }
 
 doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts

-doCorePasses passes guts = foldM (flip doCorePass) guts passes
+doCorePasses passes guts 
+  = foldM do_pass guts passes
+  where
+    do_pass guts CoreDoNothing = return guts
+    do_pass guts (CoreDoPasses ps) = doCorePasses ps guts
+    do_pass guts pass 
+       = do { dflags <- getDynFlags
+                   ; liftIO $ showPass dflags pass
+                   ; guts' <- doCorePass pass guts
+                   ; liftIO $ endPass dflags pass (mg_binds guts') (mg_rules guts')
+                   ; return guts' }

 
 doCorePass :: CorePass -> ModGuts -> CoreM ModGuts
 
 doCorePass :: CorePass -> ModGuts -> CoreM ModGuts

-doCorePass (CoreDoSimplify mode sws) = {-# SCC "Simplify" #-}
-                                       simplifyPgm mode sws
+doCorePass pass@(CoreDoSimplify {})  = {-# SCC "Simplify" #-}
+                                       simplifyPgm pass

 
 doCorePass CoreCSE                   = {-# SCC "CommonSubExpr" #-}   
 
 doCorePass CoreCSE                   = {-# SCC "CommonSubExpr" #-}   

-                                      describePass "Common sub-expression" Opt_D_dump_cse $ 

                                       doPass cseProgram
 
 doCorePass CoreLiberateCase          = {-# SCC "LiberateCase" #-}
                                       doPass cseProgram
 
 doCorePass CoreLiberateCase          = {-# SCC "LiberateCase" #-}

-                                      describePass "Liberate case" Opt_D_verbose_core2core $ 

                                        doPassD liberateCase
 
 doCorePass CoreDoFloatInwards        = {-# SCC "FloatInwards" #-}
                                        doPassD liberateCase
 
 doCorePass CoreDoFloatInwards        = {-# SCC "FloatInwards" #-}

-                                       describePass "Float inwards" Opt_D_verbose_core2core $ 

                                        doPass floatInwards
 
 doCorePass (CoreDoFloatOutwards f)   = {-# SCC "FloatOutwards" #-}
                                        doPass floatInwards
 
 doCorePass (CoreDoFloatOutwards f)   = {-# SCC "FloatOutwards" #-}

-                                       describePassD (text "Float out" <+> parens (ppr f)) 
-                                                     Opt_D_verbose_core2core $ 

                                        doPassDUM (floatOutwards f)
 
 doCorePass CoreDoStaticArgs          = {-# SCC "StaticArgs" #-}
                                        doPassDUM (floatOutwards f)
 
 doCorePass CoreDoStaticArgs          = {-# SCC "StaticArgs" #-}

-                                       describePass "Static argument" Opt_D_verbose_core2core $ 

                                        doPassU doStaticArgs
 
 doCorePass CoreDoStrictness          = {-# SCC "Stranal" #-}
                                        doPassU doStaticArgs
 
 doCorePass CoreDoStrictness          = {-# SCC "Stranal" #-}

-                                       describePass "Demand analysis" Opt_D_dump_stranal $

                                        doPassDM dmdAnalPgm
 
 doCorePass CoreDoWorkerWrapper       = {-# SCC "WorkWrap" #-}
                                        doPassDM dmdAnalPgm
 
 doCorePass CoreDoWorkerWrapper       = {-# SCC "WorkWrap" #-}

-                                       describePass "Worker Wrapper binds" Opt_D_dump_worker_wrapper $

                                        doPassU wwTopBinds
 
 doCorePass CoreDoSpecialising        = {-# SCC "Specialise" #-}
                                        doPassU wwTopBinds
 
 doCorePass CoreDoSpecialising        = {-# SCC "Specialise" #-}

-                                       describePassR "Specialise" Opt_D_dump_spec $ 

                                        doPassU specProgram
 
 doCorePass CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}
                                        doPassU specProgram
 
 doCorePass CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}

-                                       describePassR "SpecConstr" Opt_D_dump_spec $

                                        specConstrProgram
 
 doCorePass (CoreDoVectorisation be)  = {-# SCC "Vectorise" #-}
                                        specConstrProgram
 
 doCorePass (CoreDoVectorisation be)  = {-# SCC "Vectorise" #-}

-                                       describePass "Vectorisation" Opt_D_dump_vect $ 

                                        vectorise be
 
                                        vectorise be
 

-doCorePass CoreDoGlomBinds              = dontDescribePass $ doPassDM  glomBinds
-doCorePass CoreDoPrintCore              = dontDescribePass $ observe   printCore
-doCorePass (CoreDoRuleCheck phase pat)  = dontDescribePass $ ruleCheck phase pat
-
+doCorePass CoreDoGlomBinds              = doPassDM  glomBinds
+doCorePass CoreDoPrintCore              = observe   printCore
+doCorePass (CoreDoRuleCheck phase pat)  = ruleCheck phase pat

 doCorePass CoreDoNothing                = return
 doCorePass (CoreDoPasses passes)        = doCorePasses passes
 \end{code}
 doCorePass CoreDoNothing                = return
 doCorePass (CoreDoPasses passes)        = doCorePasses passes
 \end{code}

@@ -192,30 +190,6 @@ doCorePass (CoreDoPasses passes)        = doCorePasses passes
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-
-dontDescribePass :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
-dontDescribePass = ($)
-
-describePass :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
-describePass name dflag pass guts = do
-    dflags <- getDynFlags
-    
-    liftIO $ Err.showPass dflags name
-    guts' <- pass guts
-    liftIO $ endPass dflags name dflag (mg_binds guts') (mg_rules guts')
-
-    return guts'
-
-describePassD :: SDoc -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
-describePassD doc = describePass (showSDoc doc)
-
-describePassR :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
-describePassR name dflag pass guts = do
-    guts' <- describePass name dflag pass guts
-    dumpIfSet_dyn Opt_D_dump_rules "Top-level specialisations"
-                (pprRulesForUser (rulesOfBinds (mg_binds guts')))
-    return guts'
-

 printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds)
 
 ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
 printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds)
 
 ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts

@@ -468,26 +442,23 @@ glomBinds dflags binds
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-simplifyPgm :: SimplifierMode -> [SimplifierSwitch] -> ModGuts -> CoreM ModGuts
-simplifyPgm mode switches
-  = describePassD doc Opt_D_dump_simpl_phases $ \guts -> 
-    do { hsc_env <- getHscEnv
+simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts
+simplifyPgm pass guts
+  = do { hsc_env <- getHscEnv

        ; us <- getUniqueSupplyM
        ; rb <- getRuleBase
        ; liftIOWithCount $  
        ; us <- getUniqueSupplyM
        ; rb <- getRuleBase
        ; liftIOWithCount $  

-                simplifyPgmIO mode switches hsc_env us rb guts }
-  where
-    doc = ptext (sLit "Simplifier Phase") <+> text (showPpr mode) 
+                simplifyPgmIO pass hsc_env us rb guts }

 
 

-simplifyPgmIO :: SimplifierMode
-             -> [SimplifierSwitch]
+simplifyPgmIO :: CoreToDo

              -> HscEnv
              -> UniqSupply
              -> RuleBase
              -> ModGuts
              -> IO (SimplCount, ModGuts)  -- New bindings
 
              -> HscEnv
              -> UniqSupply
              -> RuleBase
              -> ModGuts
              -> IO (SimplCount, ModGuts)  -- New bindings
 

-simplifyPgmIO mode switches hsc_env us hpt_rule_base 
+simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches)
+              hsc_env us hpt_rule_base 

               guts@(ModGuts { mg_binds = binds, mg_rules = rules
                             , mg_fam_inst_env = fam_inst_env })
   = do {
               guts@(ModGuts { mg_binds = binds, mg_rules = rules
                             , mg_fam_inst_env = fam_inst_env })
   = do {

@@ -505,10 +476,7 @@ simplifyPgmIO mode switches hsc_env us hpt_rule_base
   where
     dflags              = hsc_dflags hsc_env
     dump_phase          = dumpSimplPhase dflags mode
   where
     dflags              = hsc_dflags hsc_env
     dump_phase          = dumpSimplPhase dflags mode

-                  
-    sw_chkr       = isAmongSimpl switches
-    max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
- 
+    sw_chkr     = isAmongSimpl switches

     do_iteration :: UniqSupply
                  -> Int                -- Counts iterations
                 -> SimplCount  -- Logs optimisations performed
     do_iteration :: UniqSupply
                  -> Int                -- Counts iterations
                 -> SimplCount  -- Logs optimisations performed

@@ -587,7 +555,7 @@ simplifyPgmIO mode switches hsc_env us hpt_rule_base
           let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;
 
                -- Dump the result of this iteration
           let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;
 
                -- Dump the result of this iteration

-          end_iteration dflags mode iteration_no max_iterations counts1 binds2 rules1 ;
+          end_iteration dflags pass iteration_no counts1 binds2 rules1 ;

 
                -- Loop
           do_iteration us2 (iteration_no + 1) all_counts binds2 rules1
 
                -- Loop
           do_iteration us2 (iteration_no + 1) all_counts binds2 rules1

@@ -596,18 +564,15 @@ simplifyPgmIO mode switches hsc_env us hpt_rule_base
          (us1, us2) = splitUniqSupply us
 
 -------------------
          (us1, us2) = splitUniqSupply us
 
 -------------------

-end_iteration :: DynFlags -> SimplifierMode -> Int -> Int 
+end_iteration :: DynFlags -> CoreToDo -> Int 

              -> SimplCount -> [CoreBind] -> [CoreRule] -> IO ()
 -- Same as endIteration but with simplifier counts
              -> SimplCount -> [CoreBind] -> [CoreRule] -> IO ()
 -- Same as endIteration but with simplifier counts

-end_iteration dflags mode iteration_no max_iterations counts binds rules
-  = do { Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations pass_name
-                            (pprSimplCount counts) ;
+end_iteration dflags pass iteration_no counts binds rules
+  = do { dumpIfSet (dopt Opt_D_dump_simpl_iterations dflags)
+                   pass (ptext (sLit "Simplifier counts"))
+                  (pprSimplCount counts)

 
 

-       ; endIteration dflags pass_name Opt_D_dump_simpl_iterations binds rules }
-  where
-    pass_name = "Simplifier mode " ++ showPpr mode ++ 
-               ", iteration " ++ show iteration_no ++
-               " out of " ++ show max_iterations
+       ; endIteration dflags pass iteration_no binds rules }

 \end{code}
 
 
 \end{code}
 
 

diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.lhs
index 5065f57..10bc70d 100644 (file)
--- a/compiler/simplCore/SimplMonad.lhs
+++ b/compiler/simplCore/SimplMonad.lhs
@@ -201,8 +201,6 @@ isAmongSimpl on_switches            -- Switches mentioned later occur *earlier*
     -- (avoid some unboxing, bounds checking, and other horrible things:)
     \ switch -> unsafeAt sw_tbl $ iBox (tagOf_SimplSwitch switch)
   where
     -- (avoid some unboxing, bounds checking, and other horrible things:)
     \ switch -> unsafeAt sw_tbl $ iBox (tagOf_SimplSwitch switch)
   where

-    mk_assoc_elem k@(MaxSimplifierIterations lvl)
-       = (iBox (tagOf_SimplSwitch k), SwInt lvl)

     mk_assoc_elem k
        = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
 
     mk_assoc_elem k
        = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
 

@@ -252,8 +250,7 @@ instance Ord SimplifierSwitch where
 
 
 tagOf_SimplSwitch :: SimplifierSwitch -> FastInt
 
 
 tagOf_SimplSwitch :: SimplifierSwitch -> FastInt

-tagOf_SimplSwitch (MaxSimplifierIterations _)  = _ILIT(1)
-tagOf_SimplSwitch NoCaseOfCase                 = _ILIT(2)
+tagOf_SimplSwitch NoCaseOfCase                 = _ILIT(1)

 
 -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
 
 
 -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!