Move all the CoreToDo stuff into CoreMonad

This patch moves a lot of code around, but has zero functionality change.
The idea is that the types

    CoreToDo
    SimplifierSwitch	
    SimplifierMode
    FloatOutSwitches

and 

    the main core-to-core pipeline construction

belong in simplCore/, and *not* in DynFlags.

compiler/simplCore/FloatOut.lhs

@@ -11,8 +11,9 @@ module FloatOut ( floatOutwards ) where
 import CoreSyn
 import CoreUtils
 import CoreArity	( etaExpand )
+import CoreMonad	( FloatOutSwitches(..) )
 
-import DynFlags	( DynFlags, DynFlag(..), FloatOutSwitches(..) )
+import DynFlags		( DynFlags, DynFlag(..) )
 import ErrUtils		( dumpIfSet_dyn )
 import CostCentre	( dupifyCC, CostCentre )
 import Id		( Id, idType, idArity, isBottomingId )

compiler/simplCore/SetLevels.lhs

@@ -54,8 +54,7 @@ module SetLevels (
 #include "HsVersions.h"
 
 import CoreSyn
-
-import DynFlags		( FloatOutSwitches(..) )
+import CoreMonad	( FloatOutSwitches(..) )
 import CoreUtils	( exprType, mkPiTypes )
 import CoreArity	( exprBotStrictness_maybe )
 import CoreFVs		-- all of it

compiler/simplCore/SimplCore.lhs

@@ -15,9 +15,7 @@ module SimplCore ( core2core, simplifyExpr ) where
 
 #include "HsVersions.h"
 
-import DynFlags		( CoreToDo(..), SimplifierSwitch(..),
-			  SimplifierMode(..), DynFlags, DynFlag(..), dopt,
-			  getCoreToDo, shouldDumpSimplPhase )
+import DynFlags		( DynFlags, DynFlag(..), dopt )
 import CoreSyn
 import CoreSubst
 import HscTypes
@@ -37,7 +35,6 @@ import SimplMonad
 import CoreMonad
 import qualified ErrUtils as Err 
 import CoreLint
-import CoreMonad	( endPass )
 import FloatIn		( floatInwards )
 import FloatOut		( floatOutwards )
 import FamInstEnv
@@ -507,7 +504,7 @@ simplifyPgmIO mode switches hsc_env us hpt_rule_base
     }
   where
     dflags     	 = hsc_dflags hsc_env
-    dump_phase 	 = shouldDumpSimplPhase dflags mode
+    dump_phase 	 = dumpSimplPhase dflags mode
 		   
     sw_chkr	   = isAmongSimpl switches
     max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2

compiler/simplCore/SimplEnv.lhs

@@ -40,6 +40,7 @@ module SimplEnv (
 #include "HsVersions.h"
 
 import SimplMonad
+import CoreMonad	( SimplifierMode(..) )
 import IdInfo
 import CoreSyn
 import CoreUtils
@@ -54,7 +55,6 @@ import qualified Type		( substTy, substTyVarBndr )
 import Type hiding		( substTy, substTyVarBndr )
 import Coercion
 import BasicTypes	
-import DynFlags
 import MonadUtils
 import Outputable
 import FastString

compiler/simplCore/SimplMonad.lhs

@@ -14,8 +14,7 @@ module SimplMonad (
         MonadUnique(..), newId,
 
 	-- Counting
-	SimplCount, Tick(..),
-	tick, freeTick,
+	SimplCount, tick, freeTick,
 	getSimplCount, zeroSimplCount, pprSimplCount, 
 	plusSimplCount, isZeroSimplCount,
 
@@ -29,10 +28,9 @@ import Type             ( Type )
 import FamInstEnv	( FamInstEnv )
 import Rules		( RuleBase )
 import UniqSupply
-import DynFlags		( SimplifierSwitch(..), DynFlags, DynFlag(..), dopt )
-import StaticFlags	( opt_PprStyle_Debug, opt_HistorySize )
+import DynFlags		( DynFlags )
 import Maybes		( expectJust )
-import FiniteMap	( FiniteMap, emptyFM, lookupFM, addToFM, plusFM_C, fmToList )
+import CoreMonad
 import FastString
 import Outputable
 import FastTypes
@@ -154,250 +152,17 @@ getSimplCount = SM (\_st_env us sc -> (sc, us, sc))
 
 tick :: Tick -> SimplM ()
 tick t 
-   = SM (\_st_env us sc -> let sc' = doTick t sc 
+   = SM (\_st_env us sc -> let sc' = doSimplTick t sc 
                            in sc' `seq` ((), us, sc'))
 
 freeTick :: Tick -> SimplM ()
 -- Record a tick, but don't add to the total tick count, which is
 -- used to decide when nothing further has happened
 freeTick t 
-   = SM (\_st_env us sc -> let sc' = doFreeTick t sc
+   = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc
                            in sc' `seq` ((), us, sc'))
 \end{code}
 
-\begin{code}
-verboseSimplStats :: Bool
-verboseSimplStats = opt_PprStyle_Debug		-- For now, anyway
-
-zeroSimplCount	   :: DynFlags -> SimplCount
-isZeroSimplCount   :: SimplCount -> Bool
-pprSimplCount	   :: SimplCount -> SDoc
-doTick, doFreeTick :: Tick -> SimplCount -> SimplCount
-plusSimplCount     :: SimplCount -> SimplCount -> SimplCount
-\end{code}
-
-\begin{code}
-data SimplCount 
-   = VerySimplZero		-- These two are used when 
-   | VerySimplNonZero	-- we are only interested in 
-				-- termination info
-
-   | SimplCount	{
-	ticks   :: !Int,	-- Total ticks
-	details :: !TickCounts,	-- How many of each type
-
-	n_log	:: !Int,	-- N
-	log1	:: [Tick],	-- Last N events; <= opt_HistorySize, 
-		   		--   most recent first
-	log2	:: [Tick]	-- Last opt_HistorySize events before that
-		   		-- Having log1, log2 lets us accumulate the
-				-- recent history reasonably efficiently
-     }
-
-type TickCounts = FiniteMap Tick Int
-
-zeroSimplCount dflags
-		-- This is where we decide whether to do
-		-- the VerySimpl version or the full-stats version
-  | dopt Opt_D_dump_simpl_stats dflags
-  = SimplCount {ticks = 0, details = emptyFM,
-                n_log = 0, log1 = [], log2 = []}
-  | otherwise
-  = VerySimplZero
-
-isZeroSimplCount VerySimplZero    	    = True
-isZeroSimplCount (SimplCount { ticks = 0 }) = True
-isZeroSimplCount _    			    = False
-
-doFreeTick tick sc@SimplCount { details = dts } 
-  = sc { details = dts `addTick` tick }
-doFreeTick _ sc = sc 
-
-doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }
-  | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
-  | otherwise		  = sc1 { n_log = nl+1, log1 = tick : l1 }
-  where
-    sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
-
-doTick _ _ = VerySimplNonZero -- The very simple case
-
-
--- Don't use plusFM_C because that's lazy, and we want to 
--- be pretty strict here!
-addTick :: TickCounts -> Tick -> TickCounts
-addTick fm tick = case lookupFM fm tick of
-			Nothing -> addToFM fm tick 1
-			Just n  -> n1 `seq` addToFM fm tick n1
-				where
-				   n1 = n+1
-
-
-plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
-	       sc2@(SimplCount { ticks = tks2, details = dts2 })
-  = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
-  where
-	-- A hackish way of getting recent log info
-    log_base | null (log1 sc2) = sc1	-- Nothing at all in sc2
-	     | null (log2 sc2) = sc2 { log2 = log1 sc1 }
-	     | otherwise       = sc2
-
-plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
-plusSimplCount _             _             = VerySimplNonZero
-
-pprSimplCount VerySimplZero    = ptext (sLit "Total ticks: ZERO!")
-pprSimplCount VerySimplNonZero = ptext (sLit "Total ticks: NON-ZERO!")
-pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
-  = vcat [ptext (sLit "Total ticks:    ") <+> int tks,
-	  blankLine,
-	  pprTickCounts (fmToList dts),
-	  if verboseSimplStats then
-		vcat [blankLine,
-		      ptext (sLit "Log (most recent first)"),
-		      nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
-	  else empty
-    ]
-
-pprTickCounts :: [(Tick,Int)] -> SDoc
-pprTickCounts [] = empty
-pprTickCounts ((tick1,n1):ticks)
-  = vcat [int tot_n <+> text (tickString tick1),
-	  pprTCDetails real_these,
-	  pprTickCounts others
-    ]
-  where
-    tick1_tag		= tickToTag tick1
-    (these, others)	= span same_tick ticks
-    real_these		= (tick1,n1):these
-    same_tick (tick2,_) = tickToTag tick2 == tick1_tag
-    tot_n		= sum [n | (_,n) <- real_these]
-
-pprTCDetails :: [(Tick, Int)] -> SDoc
-pprTCDetails ticks
-  = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{Ticks}
-%*									*
-%************************************************************************
-
-\begin{code}
-data Tick
-  = PreInlineUnconditionally	Id
-  | PostInlineUnconditionally	Id
-
-  | UnfoldingDone    		Id
-  | RuleFired			FastString	-- Rule name
-
-  | LetFloatFromLet
-  | EtaExpansion		Id	-- LHS binder
-  | EtaReduction		Id	-- Binder on outer lambda
-  | BetaReduction		Id	-- Lambda binder
-
-
-  | CaseOfCase			Id	-- Bndr on *inner* case
-  | KnownBranch			Id	-- Case binder
-  | CaseMerge			Id	-- Binder on outer case
-  | AltMerge			Id	-- Case binder
-  | CaseElim			Id	-- Case binder
-  | CaseIdentity		Id	-- Case binder
-  | FillInCaseDefault		Id	-- Case binder
-
-  | BottomFound		
-  | SimplifierDone		-- Ticked at each iteration of the simplifier
-
-instance Outputable Tick where
-  ppr tick = text (tickString tick) <+> pprTickCts tick
-
-instance Eq Tick where
-  a == b = case a `cmpTick` b of
-           EQ -> True
-           _ -> False
-
-instance Ord Tick where
-  compare = cmpTick
-
-tickToTag :: Tick -> Int
-tickToTag (PreInlineUnconditionally _)	= 0
-tickToTag (PostInlineUnconditionally _)	= 1
-tickToTag (UnfoldingDone _)		= 2
-tickToTag (RuleFired _)			= 3
-tickToTag LetFloatFromLet		= 4
-tickToTag (EtaExpansion _)		= 5
-tickToTag (EtaReduction _)		= 6
-tickToTag (BetaReduction _)		= 7
-tickToTag (CaseOfCase _)		= 8
-tickToTag (KnownBranch _)		= 9
-tickToTag (CaseMerge _)			= 10
-tickToTag (CaseElim _)			= 11
-tickToTag (CaseIdentity _)		= 12
-tickToTag (FillInCaseDefault _)		= 13
-tickToTag BottomFound			= 14
-tickToTag SimplifierDone		= 16
-tickToTag (AltMerge _)			= 17
-
-tickString :: Tick -> String
-tickString (PreInlineUnconditionally _)	= "PreInlineUnconditionally"
-tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
-tickString (UnfoldingDone _)		= "UnfoldingDone"
-tickString (RuleFired _)		= "RuleFired"
-tickString LetFloatFromLet		= "LetFloatFromLet"
-tickString (EtaExpansion _)		= "EtaExpansion"
-tickString (EtaReduction _)		= "EtaReduction"
-tickString (BetaReduction _)		= "BetaReduction"
-tickString (CaseOfCase _)		= "CaseOfCase"
-tickString (KnownBranch _)		= "KnownBranch"
-tickString (CaseMerge _)		= "CaseMerge"
-tickString (AltMerge _)			= "AltMerge"
-tickString (CaseElim _)			= "CaseElim"
-tickString (CaseIdentity _)		= "CaseIdentity"
-tickString (FillInCaseDefault _)	= "FillInCaseDefault"
-tickString BottomFound			= "BottomFound"
-tickString SimplifierDone		= "SimplifierDone"
-
-pprTickCts :: Tick -> SDoc
-pprTickCts (PreInlineUnconditionally v)	= ppr v
-pprTickCts (PostInlineUnconditionally v)= ppr v
-pprTickCts (UnfoldingDone v)		= ppr v
-pprTickCts (RuleFired v)		= ppr v
-pprTickCts LetFloatFromLet		= empty
-pprTickCts (EtaExpansion v)		= ppr v
-pprTickCts (EtaReduction v)		= ppr v
-pprTickCts (BetaReduction v)		= ppr v
-pprTickCts (CaseOfCase v)		= ppr v
-pprTickCts (KnownBranch v)		= ppr v
-pprTickCts (CaseMerge v)		= ppr v
-pprTickCts (AltMerge v)			= ppr v
-pprTickCts (CaseElim v)			= ppr v
-pprTickCts (CaseIdentity v)		= ppr v
-pprTickCts (FillInCaseDefault v)	= ppr v
-pprTickCts _    			= empty
-
-cmpTick :: Tick -> Tick -> Ordering
-cmpTick a b = case (tickToTag a `compare` tickToTag b) of
-		GT -> GT
-		EQ -> cmpEqTick a b
-		LT -> LT
-
-cmpEqTick :: Tick -> Tick -> Ordering
-cmpEqTick (PreInlineUnconditionally a)	(PreInlineUnconditionally b)	= a `compare` b
-cmpEqTick (PostInlineUnconditionally a)	(PostInlineUnconditionally b)	= a `compare` b
-cmpEqTick (UnfoldingDone a)		(UnfoldingDone b)		= a `compare` b
-cmpEqTick (RuleFired a)			(RuleFired b)			= a `compare` b
-cmpEqTick (EtaExpansion a)		(EtaExpansion b)		= a `compare` b
-cmpEqTick (EtaReduction a)		(EtaReduction b)		= a `compare` b
-cmpEqTick (BetaReduction a)		(BetaReduction b)		= a `compare` b
-cmpEqTick (CaseOfCase a)		(CaseOfCase b)			= a `compare` b
-cmpEqTick (KnownBranch a)		(KnownBranch b)			= a `compare` b
-cmpEqTick (CaseMerge a)			(CaseMerge b)			= a `compare` b
-cmpEqTick (AltMerge a)			(AltMerge b)			= a `compare` b
-cmpEqTick (CaseElim a)			(CaseElim b)			= a `compare` b
-cmpEqTick (CaseIdentity a)		(CaseIdentity b)		= a `compare` b
-cmpEqTick (FillInCaseDefault a)		(FillInCaseDefault b)		= a `compare` b
-cmpEqTick _     			_     				= EQ
-\end{code}
-
 
 %************************************************************************
 %*									*

compiler/simplCore/SimplUtils.lhs

@@ -28,6 +28,7 @@ module SimplUtils (
 #include "HsVersions.h"
 
 import SimplEnv
+import CoreMonad	( SimplifierMode(..), Tick(..) )
 import DynFlags
 import StaticFlags
 import CoreSyn
@@ -601,15 +602,13 @@ updModeForInlineRules inline_rule_act current_mode
       ActiveBefore {} -> mk_gentle current_mode
       ActiveAfter n   -> mk_phase n current_mode
   where
-    no_op  = SimplGently { sm_rules = False, sm_inline = False }
+    no_op = SimplGently { sm_rules = False, sm_inline = False }
 
     mk_gentle (SimplGently {}) = current_mode
-    mk_gentle _                = SimplGently { sm_rules = True,  sm_inline = True }
+    mk_gentle _                = SimplGently { sm_rules = True, sm_inline = True }
 
-    mk_phase n (SimplPhase cp ss) 
-                    | cp > n    = no_op	-- Current phase earlier than n
-                    | otherwise = SimplPhase n ss
-    mk_phase _ (SimplGently {}) = no_op
+    mk_phase n (SimplPhase _ ss) = SimplPhase n ss
+    mk_phase n (SimplGently {})  = SimplPhase n ["gentle-rules"]
 \end{code}
 
 

compiler/simplCore/Simplify.lhs

@@ -18,10 +18,11 @@ import Id
 import MkId		( mkImpossibleExpr, seqId )
 import Var
 import IdInfo
-import Name		( mkSystemVarName )
+import Name		( mkSystemVarName, isExternalName )
 import Coercion
 import FamInstEnv       ( topNormaliseType )
 import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness )
+import CoreMonad	( SimplifierSwitch(..), Tick(..) )
 import CoreSyn
 import Demand           ( isStrictDmd, splitStrictSig )
 import PprCore          ( pprParendExpr, pprCoreExpr )
@@ -674,12 +675,14 @@ simplUnfolding env top_lvl id _ _
     (CoreUnfolding { uf_tmpl = expr, uf_arity = arity
                    , uf_src = src, uf_guidance = guide })
   | isInlineRuleSource src
-  = do { expr' <- simplExpr rule_env expr
+  = -- pprTrace "su" (vcat [ppr id, ppr act, ppr (getMode env), ppr (getMode rule_env)]) $
+    do { expr' <- simplExpr rule_env expr
        ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst env) src
        ; return (mkCoreUnfolding (isTopLevel top_lvl) src' expr' arity guide) }
 		-- See Note [Top-level flag on inline rules] in CoreUnfold
   where
-    rule_env = updMode (updModeForInlineRules (idInlineActivation id)) env
+    act      = idInlineActivation id
+    rule_env = updMode (updModeForInlineRules act) env
        	       -- See Note [Simplifying gently inside InlineRules] in SimplUtils
 
 simplUnfolding _ top_lvl id _occ_info new_rhs _