Add a class HasDynFlags(getDynFlags)
[ghc.git] / compiler / simplCore / CoreMonad.lhs
index df515d1..ab69916 100644 (file)
@@ -4,6 +4,13 @@
 \section[CoreMonad]{The core pipeline monad}
 
 \begin{code}
+{-# OPTIONS -fno-warn-tabs #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and
+-- detab the module (please do the detabbing in a separate patch). See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
+-- for details
+
 {-# LANGUAGE UndecidableInstances #-}
 
 module CoreMonad (
@@ -128,7 +135,7 @@ stuff before and after core passes, and do Core Lint when necessary.
 showPass :: DynFlags -> CoreToDo -> IO ()
 showPass dflags pass = Err.showPass dflags (showSDoc (ppr pass))
 
-endPass :: DynFlags -> CoreToDo -> [CoreBind] -> [CoreRule] -> IO ()
+endPass :: DynFlags -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
 endPass dflags pass binds rules
   = do { dumpPassResult dflags mb_flag (ppr pass) empty binds rules
        ; lintPassResult dflags pass binds }      
@@ -147,7 +154,7 @@ dumpPassResult :: DynFlags
                                        --            name is specified by df
                -> SDoc                         -- Header
                -> SDoc                         -- Extra info to appear after header
-               -> [CoreBind] -> [CoreRule] 
+               -> CoreProgram -> [CoreRule] 
                -> IO ()
 dumpPassResult dflags mb_flag hdr extra_info binds rules
   | Just dflag <- mb_flag
@@ -169,7 +176,7 @@ dumpPassResult dflags mb_flag hdr extra_info binds rules
                     , ptext (sLit "------ Local rules for imported ids --------")
                     , pprRules rules ]
 
-lintPassResult :: DynFlags -> CoreToDo -> [CoreBind] -> IO ()
+lintPassResult :: DynFlags -> CoreToDo -> CoreProgram -> IO ()
 lintPassResult dflags pass binds
   = when (dopt Opt_DoCoreLinting dflags) $
     do { let (warns, errs) = lintCoreBindings binds
@@ -177,7 +184,7 @@ lintPassResult dflags pass binds
        ; displayLintResults dflags pass warns errs binds  }
 
 displayLintResults :: DynFlags -> CoreToDo
-                   -> Bag Err.Message -> Bag Err.Message -> [CoreBind]
+                   -> Bag Err.Message -> Bag Err.Message -> CoreProgram
                    -> IO ()
 displayLintResults dflags pass warns errs binds
   | not (isEmptyBag errs)
@@ -244,8 +251,9 @@ data CoreToDo           -- These are diff core-to-core passes,
   | 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
+  | CoreDesugar    -- Right after desugaring, no simple optimisation yet!
+  | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces
+                       --                 Core output, and hence useful to pass to endPass
 
   | CoreTidy
   | CorePrep
@@ -267,6 +275,7 @@ 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 CoreDesugarOpt           = Just Opt_D_dump_ds 
 coreDumpFlag CoreTidy                 = Just Opt_D_dump_simpl
 coreDumpFlag CorePrep                 = Just Opt_D_dump_prep
 
@@ -288,7 +297,8 @@ instance Outputable CoreToDo where
   ppr CoreDoSpecConstr         = ptext (sLit "SpecConstr")
   ppr CoreCSE                  = ptext (sLit "Common sub-expression")
   ppr CoreDoVectorisation      = ptext (sLit "Vectorisation")
-  ppr CoreDesugar              = ptext (sLit "Desugar")
+  ppr CoreDesugar              = ptext (sLit "Desugar (before optimization)")
+  ppr CoreDesugarOpt           = ptext (sLit "Desugar (after optimization)")
   ppr CoreTidy                 = ptext (sLit "Tidy Core")
   ppr CorePrep                        = ptext (sLit "CorePrep")
   ppr CoreDoPrintCore          = ptext (sLit "Print core")
@@ -444,7 +454,7 @@ defaultPlugin = Plugin {
 -- | A description of the plugin pass itself
 type PluginPass = ModGuts -> CoreM ModGuts
 
-bindsOnlyPass :: ([CoreBind] -> CoreM [CoreBind]) -> ModGuts -> CoreM ModGuts
+bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts
 bindsOnlyPass pass guts
   = do { binds' <- pass (mg_binds guts)
        ; return (guts { mg_binds = binds' }) }
@@ -855,8 +865,8 @@ addSimplCount count = write (CoreWriter { cw_simpl_count = count })
 
 -- Convenience accessors for useful fields of HscEnv
 
-getDynFlags :: CoreM DynFlags
-getDynFlags = fmap hsc_dflags getHscEnv
+instance HasDynFlags CoreM where
+    getDynFlags = fmap hsc_dflags getHscEnv
 
 -- | The original name cache is the current mapping from 'Module' and
 -- 'OccName' to a compiler-wide unique 'Name'