X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplMonad.lhs;h=bc09e1128ce96c8dbc97fa159b21b3e52e003aa8;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=879bd2c9da22ce212a9256a5d7989a528939d4c6;hpb=7a3bd641457666e10d0a47be9f22762e03defbf0;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs
index 879bd2c..bc09e11 100644
--- a/ghc/compiler/simplCore/SimplMonad.lhs
+++ b/ghc/compiler/simplCore/SimplMonad.lhs
@@ -1,41 +1,57 @@
 %
-% (c) The AQUA Project, Glasgow University, 1993-1996
+% (c) The AQUA Project, Glasgow University, 1993-1998
 %
 \section[SimplMonad]{The simplifier Monad}
 
 \begin{code}
-#include "HsVersions.h"
-
 module SimplMonad (
-	SYN_IE(SmplM),
+	-- The monad
+	SimplM,
 	initSmpl, returnSmpl, thenSmpl, thenSmpl_,
-	mapSmpl, mapAndUnzipSmpl,
+	mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl,
+	getDOptsSmpl,
 
-	-- Counting
-	SimplCount{-abstract-}, TickType(..), tick, tickN,
-	simplCount, detailedSimplCount,
-	zeroSimplCount, showSimplCount, combineSimplCounts,
+        -- Unique supply
+        getUniqueSmpl, getUniquesSmpl, getUniqSupplySmpl, newId,
 
-	-- Cloning
-	cloneId, cloneIds, cloneTyVarSmpl, newIds, newId
+	-- Counting
+	SimplCount, Tick(..),
+	tick, freeTick,
+	getSimplCount, zeroSimplCount, pprSimplCount, 
+	plusSimplCount, isZeroSimplCount,
+
+	-- Switch checker
+	SwitchChecker, SwitchResult(..), getSimplIntSwitch,
+	isAmongSimpl, intSwitchSet, switchIsOn
     ) where
 
-IMP_Ubiq(){-uitous-}
-IMPORT_1_3(Ix)
-
-IMPORT_DELOOPER(SmplLoop)		-- well, cheating sort of
+#include "HsVersions.h"
 
-import Id		( mkSysLocal, mkIdWithNewUniq )
-import CoreUnfold	( SimpleUnfolding )
-import SimplEnv
-import SrcLoc		( noSrcLoc )
-import TyVar		( cloneTyVar )
-import UniqSupply	( getUnique, getUniques, splitUniqSupply,
+import Id		( Id, mkSysLocal )
+import Type             ( Type )
+import UniqSupply	( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
 			  UniqSupply
 			)
-import Util		( zipWithEqual, panic )
+import DynFlags		( SimplifierSwitch(..), DynFlags, DynFlag(..), dopt )
+import StaticFlags	( opt_PprStyle_Debug, opt_HistorySize )
+import Unique		( Unique )
+import Maybes		( expectJust )
+import FiniteMap	( FiniteMap, emptyFM, isEmptyFM, lookupFM, addToFM, plusFM_C, fmToList )
+import FastString	( FastString )
+import Outputable
+import FastTypes
+
+import GLAEXTS		( indexArray# )
+
+#if __GLASGOW_HASKELL__ < 503
+import PrelArr  ( Array(..) )
+#else
+import GHC.Arr  ( Array(..) )
+#endif
+
+import Array		( array, (//) )
 
-infixr 9  `thenSmpl`, `thenSmpl_`
+infixr 0  `thenSmpl`, `thenSmpl_`
 \end{code}
 
 %************************************************************************
@@ -48,41 +64,54 @@ For the simplifier monad, we want to {\em thread} a unique supply and a counter.
 (Command-line switches move around through the explicitly-passed SimplEnv.)
 
 \begin{code}
-type SmplM result
-  = UniqSupply
-  -> SimplCount    -- things being threaded
-  -> (result, SimplCount)
+newtype SimplM result
+  =  SM  { unSM :: DynFlags		-- We thread the unique supply because
+		   -> UniqSupply	-- constantly splitting it is rather expensive
+		   -> SimplCount 
+		   -> (result, UniqSupply, SimplCount)}
 \end{code}
 
 \begin{code}
-initSmpl :: UniqSupply -- no init count; set to 0
-	  -> SmplM a
-	  -> (a, SimplCount)
+initSmpl :: DynFlags
+	 -> UniqSupply		-- No init count; set to 0
+	 -> SimplM a
+	 -> (a, SimplCount)
+
+initSmpl dflags us m
+  = case unSM m dflags us (zeroSimplCount dflags) of 
+	(result, _, count) -> (result, count)
 
-initSmpl us m = m us zeroSimplCount
 
 {-# INLINE thenSmpl #-}
 {-# INLINE thenSmpl_ #-}
 {-# INLINE returnSmpl #-}
 
-returnSmpl :: a -> SmplM a
-returnSmpl e us sc = (e, sc)
+instance Monad SimplM where
+   (>>)   = thenSmpl_
+   (>>=)  = thenSmpl
+   return = returnSmpl
+
+returnSmpl :: a -> SimplM a
+returnSmpl e = SM (\ dflags us sc -> (e, us, sc))
 
-thenSmpl  :: SmplM a -> (a -> SmplM b) -> SmplM b
-thenSmpl_ :: SmplM a -> SmplM b -> SmplM b
+thenSmpl  :: SimplM a -> (a -> SimplM b) -> SimplM b
+thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
 
-thenSmpl m k us sc0
-  = case splitUniqSupply us of { (s1, s2) ->
-    case (m s1 sc0)	    of { (m_result, sc1) ->
-    k m_result s2 sc1 }}
+thenSmpl m k 
+  = SM (\ dflags us0 sc0 ->
+	  case (unSM m dflags us0 sc0) of 
+		(m_result, us1, sc1) -> unSM (k m_result) dflags us1 sc1 )
+
+thenSmpl_ m k 
+  = SM (\dflags us0 sc0 ->
+	 case (unSM m dflags us0 sc0) of 
+		(_, us1, sc1) -> unSM k dflags us1 sc1)
+\end{code}
 
-thenSmpl_ m k us sc0
-  = case splitUniqSupply us of { (s1, s2) ->
-    case (m s1 sc0) 	    of { (_, sc1) ->
-    k s2 sc1 }}
 
-mapSmpl	    	:: (a -> SmplM b) -> [a] -> SmplM [b]
-mapAndUnzipSmpl :: (a -> SmplM (b, c)) -> [a] -> SmplM ([b],[c])
+\begin{code}
+mapSmpl	    	:: (a -> SimplM b) -> [a] -> SimplM [b]
+mapAndUnzipSmpl :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c])
 
 mapSmpl f [] = returnSmpl []
 mapSmpl f (x:xs)
@@ -95,249 +124,403 @@ mapAndUnzipSmpl f (x:xs)
   = f x			    `thenSmpl` \ (r1,  r2)  ->
     mapAndUnzipSmpl f xs    `thenSmpl` \ (rs1, rs2) ->
     returnSmpl (r1:rs1, r2:rs2)
+
+mapAccumLSmpl :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c])
+mapAccumLSmpl f acc []     = returnSmpl (acc, [])
+mapAccumLSmpl f acc (x:xs) = f acc x	`thenSmpl` \ (acc', x') ->
+			     mapAccumLSmpl f acc' xs	`thenSmpl` \ (acc'', xs') ->
+			     returnSmpl (acc'', x':xs')
 \end{code}
 
 
 %************************************************************************
 %*									*
-\subsection{Counting up what we've done}
+\subsection{The unique supply}
 %*									*
 %************************************************************************
 
-The assoc list isn't particularly costly, because we only use
-the number of ticks in ``real life.''
+\begin{code}
+getUniqSupplySmpl :: SimplM UniqSupply
+getUniqSupplySmpl 
+   = SM (\dflags us sc -> case splitUniqSupply us of
+			        (us1, us2) -> (us1, us2, sc))
+
+getUniqueSmpl :: SimplM Unique
+getUniqueSmpl 
+   = SM (\dflags us sc -> case splitUniqSupply us of
+			        (us1, us2) -> (uniqFromSupply us1, us2, sc))
+
+getUniquesSmpl :: SimplM [Unique]
+getUniquesSmpl 
+   = SM (\dflags us sc -> case splitUniqSupply us of
+			        (us1, us2) -> (uniqsFromSupply us1, us2, sc))
+
+getDOptsSmpl :: SimplM DynFlags
+getDOptsSmpl 
+   = SM (\dflags us sc -> (dflags, us, sc))
+
+newId :: FastString -> Type -> SimplM Id
+newId fs ty = getUniqueSmpl 	`thenSmpl` \ uniq ->
+	      returnSmpl (mkSysLocal fs uniq ty)
+\end{code}
+
 
-The right thing to do, if you want that to go fast, is thread
-a mutable array through @SimplM@.
+%************************************************************************
+%*									*
+\subsection{Counting up what we've done}
+%*									*
+%************************************************************************
 
 \begin{code}
-data SimplCount
-  = SimplCount	FAST_INT	    -- number of ticks
-		[(TickType, Int)]   -- assoc list of all diff kinds of ticks
-
-data TickType
-  = UnfoldingDone    | MagicUnfold	| ConReused
-  | CaseFloatFromLet | CaseOfCase
-  | LetFloatFromLet  | LetFloatFromCase
-  | KnownBranch	     | Let2Case
-  | CaseMerge	     | CaseElim
-  | CaseIdentity
-  | AtomicRhs	-- Rhs of a let-expression was an atom
-  | EtaExpansion
-  | CaseOfError
-  | TyBetaReduction
-  | BetaReduction
-  | SpecialisationDone
-  {- BEGIN F/B ENTRIES -}
-  -- the 8 rules
-  | FoldrBuild	     	-- foldr f z (build g) ==>
-  | FoldrAugment	-- foldr f z (augment g z) ==>
-  | Foldr_Nil		-- foldr f z [] ==>
-  | Foldr_List		-- foldr f z (x:...) ==>
-
-  | FoldlBuild	        -- foldl f z (build g) ==>
-  | FoldlAugment	-- foldl f z (augment g z) ==>
-  | Foldl_Nil		-- foldl f z [] ==>
-  | Foldl_List		-- foldl f z (x:...) ==>
-
-  | Foldr_Cons_Nil	-- foldr (:) [] => id
-  | Foldr_Cons		-- foldr (:) => flip (++)
-
-  | Str_FoldrStr	-- foldr f z "hello" => unpackFoldrPS__ f z "hello"
-  | Str_UnpackCons	-- unpackFoldrPS# (:) z "hello" => unpackAppendPS__ z "hello"
-  | Str_UnpackNil	-- unpackAppendPS__ [] "hello" => "hello"
-  {- END F/B ENTRIES -}
-  deriving (Eq, Ord, Ix)
-
-instance Text TickType where
-    showsPrec p UnfoldingDone	= showString "UnfoldingDone    "
-    showsPrec p MagicUnfold	= showString "MagicUnfold      "
-    showsPrec p ConReused	= showString "ConReused        "
-    showsPrec p CaseFloatFromLet= showString "CaseFloatFromLet "
-    showsPrec p CaseOfCase	= showString "CaseOfCase       "
-    showsPrec p LetFloatFromLet	= showString "LetFloatFromLet  "
-    showsPrec p LetFloatFromCase= showString "LetFloatFromCase "
-    showsPrec p KnownBranch	= showString "KnownBranch      "
-    showsPrec p Let2Case	= showString "Let2Case         "
-    showsPrec p CaseMerge	= showString "CaseMerge        "
-    showsPrec p CaseElim	= showString "CaseElim         "
-    showsPrec p CaseIdentity	= showString "CaseIdentity     "
-    showsPrec p AtomicRhs	= showString "AtomicRhs        "
-    showsPrec p EtaExpansion	= showString "EtaExpansion     "
-    showsPrec p CaseOfError	= showString "CaseOfError      "
-    showsPrec p TyBetaReduction	= showString "TyBetaReduction  "
-    showsPrec p BetaReduction	= showString "BetaReduction    "
-    showsPrec p SpecialisationDone 
-				= showString "Specialisation   "
-
-	-- Foldr/Build Stuff:
-    showsPrec p FoldrBuild	= showString "FoldrBuild       "
-    showsPrec p FoldrAugment	= showString "FoldrAugment     "
-    showsPrec p Foldr_Nil	= showString "Foldr_Nil        "
-    showsPrec p Foldr_List	= showString "Foldr_List       "
-
-    showsPrec p FoldlBuild	= showString "FoldlBuild       "
-    showsPrec p FoldlAugment	= showString "FoldlAugment     "
-    showsPrec p Foldl_Nil	= showString "Foldl_Nil        "
-    showsPrec p Foldl_List	= showString "Foldl_List       "
-
-    showsPrec p Foldr_Cons_Nil	= showString "Foldr_Cons_Nil   "
-    showsPrec p Foldr_Cons	= showString "Foldr_Cons       "
-
-    showsPrec p Str_FoldrStr	= showString "Str_FoldrStr     "
-    showsPrec p Str_UnpackCons  = showString "Str_UnpackCons   "
-    showsPrec p Str_UnpackNil   = showString "Str_UnpackNil    "
-
-showSimplCount :: SimplCount -> String
-
-showSimplCount (SimplCount _ stuff)
-  = shw stuff
-  where
-    shw []	    = ""
-    shw ((t,n):tns) | n /= 0	= show t ++ ('\t' : show n) ++ ('\n' : shw tns)
-		    | otherwise = shw tns
-
-zeroSimplCount :: SimplCount
-zeroSimplCount
-  = SimplCount ILIT(0)
-      [ (UnfoldingDone, 0),
-	(MagicUnfold, 0),
-	(ConReused, 0),
-	(CaseFloatFromLet, 0),
-	(CaseOfCase, 0),
-	(LetFloatFromLet, 0),
-	(LetFloatFromCase, 0),
-	(KnownBranch, 0),
-	(Let2Case, 0),
-	(CaseMerge, 0),
-	(CaseElim, 0),
-	(CaseIdentity, 0),
-	(AtomicRhs, 0),
-	(EtaExpansion, 0),
-	(CaseOfError, 0),
-	(TyBetaReduction,0),
-	(BetaReduction,0),
-	(SpecialisationDone,0),
-	-- Foldr/Build Stuff:
-	(FoldrBuild, 0),
-	(FoldrAugment, 0),
-	(Foldr_Nil, 0),
-	(Foldr_List, 0),
-	(FoldlBuild, 0),
-	(FoldlAugment, 0),
-	(Foldl_Nil, 0),
-	(Foldl_List, 0),
-	(Foldr_Cons_Nil, 0),
-	(Foldr_Cons, 0),
-
-	(Str_FoldrStr, 0),
-	(Str_UnpackCons, 0),
-	(Str_UnpackNil, 0) ]
---
---= array (con2tag_TickType UnfoldingDone, con2tag_TickType FoldrInline)
---        [ i := 0 | i <- indices zeroSimplCount ]
+getSimplCount :: SimplM SimplCount
+getSimplCount = SM (\dflags us sc -> (sc, us, sc))
+
+tick :: Tick -> SimplM ()
+tick t 
+   = SM (\dflags us sc -> let sc' = doTick 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 (\dflags us sc -> let sc' = doFreeTick t sc
+			  in sc' `seq` ((), us, sc'))
 \end{code}
 
-Counting-related monad functions:
 \begin{code}
-tick :: TickType -> SmplM ()
+verboseSimplStats = opt_PprStyle_Debug		-- For now, anyway
 
-tick tick_type us (SimplCount n stuff)
-  = ((), SimplCount (n _ADD_ ILIT(1))
-#ifdef OMIT_SIMPL_COUNTS
-		    stuff -- don't change anything
-#else
-		    (inc_tick stuff)
-#endif
-    )
+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
+			log2	:: [Tick]		-- Last opt_HistorySize events before that
+		  }
+
+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 other			    = False
+
+doFreeTick tick sc@SimplCount { details = dts } 
+  = dts' `seqFM` sc { details = dts' }
   where
-    inc_tick [] = panic "couldn't inc_tick!"
-    inc_tick (x@(ttype, cnt) : xs)
-      = if ttype == tick_type then
-	    let
-		incd = cnt + 1
-	    in
-	    (ttype, incd) : xs
-	else
-	    x : inc_tick xs
-
-tickN :: TickType -> Int -> SmplM ()
-
-tickN tick_type 0 us counts 
-  = ((), counts)
-tickN tick_type IBOX(increment) us (SimplCount n stuff)
-  = ((), SimplCount (n _ADD_ increment)
-#ifdef OMIT_SIMPL_COUNTS
-		    stuff -- don't change anything
-#else
-		    (inc_tick stuff)
-#endif
-    )
+    dts' = dts `addTick` tick 
+doFreeTick tick sc = sc 
+
+-- Gross hack to persuade GHC 3.03 to do this important seq
+seqFM fm x | isEmptyFM fm = x
+	   | otherwise    = x
+
+doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1, log2 = l2 }
+  | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
+  | otherwise		  = sc1 { n_log = nl+1, log1 = tick : l1 }
   where
-    inc_tick [] = panic "couldn't inc_tick!"
-    inc_tick (x@(ttype, cnt) : xs)
-      = if ttype == tick_type then
-	    let
-		incd = cnt + IBOX(increment)
-	    in
-	    (ttype, incd) : xs
-	else
-	    x : inc_tick xs
-
-simplCount :: SmplM Int
-simplCount us sc@(SimplCount n _) = (IBOX(n), sc)
-
-detailedSimplCount :: SmplM SimplCount
-detailedSimplCount us sc = (sc, sc)
-
-combineSimplCounts :: SimplCount -> SimplCount -> SimplCount
-
-#ifdef OMIT_SIMPL_COUNTS
-combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2)
-  = SimplCount (n1 _ADD_ n2)
-	       stuff1 -- just pick one
-#else
-combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2)
-  = SimplCount (n1 _ADD_ n2)
-	       (zipWithEqual "combineSimplCounts" (\ (t1,c1) (t2,c2) -> (t1,c1+c2)) stuff1 stuff2)
-#endif
+    sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
+
+doTick tick sc = 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 sc1	     sc2	   = 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,
+	  text "",
+	  pprTickCounts (fmToList dts),
+	  if verboseSimplStats then
+		vcat [text "",
+		      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 ticks@((tick,_):_)
+  | verboseSimplStats || isRuleFired tick
+  = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
+  | otherwise
+  = empty
 \end{code}
 
 %************************************************************************
 %*									*
-\subsection{Monad primitives}
+\subsection{Ticks}
 %*									*
 %************************************************************************
 
 \begin{code}
-newId :: Type -> SmplM Id
-newId ty us sc
-  = (mkSysLocal SLIT("s") uniq ty noSrcLoc, sc)
-  where
-    uniq = getUnique us
+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
+
+isRuleFired (RuleFired _) = True
+isRuleFired other	  = False
+
+instance Outputable Tick where
+  ppr tick = text (tickString tick) <+> pprTickCts tick
+
+instance Eq Tick where
+  a == b = case a `cmpTick` b of { EQ -> True; other -> 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 other			= empty
+
+cmpTick :: Tick -> Tick -> Ordering
+cmpTick a b = case (tickToTag a `compare` tickToTag b) of
+		GT -> GT
+		EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b
+		   | otherwise				-> EQ
+		LT -> LT
+	-- Always distinguish RuleFired, so that the stats
+	-- can report them even in non-verbose mode
+
+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 other1			other2				= EQ
+\end{code}
 
-newIds :: [Type] -> SmplM [Id]
-newIds tys us sc
-  = (zipWithEqual "newIds" mk_id tys uniqs, sc)
-  where
-    uniqs  = getUniques (length tys) us
-    mk_id ty uniq = mkSysLocal SLIT("s") uniq ty noSrcLoc
 
-cloneTyVarSmpl :: TyVar -> SmplM TyVar
+%************************************************************************
+%*									*
+\subsubsection{Command-line switches}
+%*									*
+%************************************************************************
 
-cloneTyVarSmpl tyvar us sc
-  = (new_tyvar, sc)
+\begin{code}
+type SwitchChecker = SimplifierSwitch -> SwitchResult
+
+data SwitchResult
+  = SwBool	Bool		-- on/off
+  | SwString	FastString	-- nothing or a String
+  | SwInt	Int		-- nothing or an Int
+
+isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
+isAmongSimpl on_switches		-- Switches mentioned later occur *earlier*
+					-- in the list; defaults right at the end.
+  = let
+	tidied_on_switches = foldl rm_dups [] on_switches
+		-- The fold*l* ensures that we keep the latest switches;
+		-- ie the ones that occur earliest in the list.
+
+	sw_tbl :: Array Int SwitchResult
+	sw_tbl = (array	(0, lAST_SIMPL_SWITCH_TAG) -- bounds...
+			all_undefined)
+		 // defined_elems
+
+	all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
+
+	defined_elems = map mk_assoc_elem tidied_on_switches
+    in
+    -- (avoid some unboxing, bounds checking, and other horrible things:)
+    case sw_tbl of { Array _ _ stuff ->
+    \ switch ->
+	case (indexArray# stuff (tagOf_SimplSwitch switch)) of
+	  (# v #) -> v
+    }
   where
-   uniq = getUnique us
-   new_tyvar = cloneTyVar tyvar uniq
+    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!
+
+    -- cannot have duplicates if we are going to use the array thing
+    rm_dups switches_so_far switch
+      = if switch `is_elem` switches_so_far
+    	then switches_so_far
+	else switch : switches_so_far
+      where
+	sw `is_elem` []     = False
+	sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
+			    || sw `is_elem` ss
+\end{code}
 
-cloneId :: SimplEnv -> InBinder -> SmplM OutId
-cloneId env (id,_) us sc
-  = (mkIdWithNewUniq id_with_new_ty uniq, sc)
-  where
-    id_with_new_ty = simplTyInId env id
-    uniq = getUnique us
+\begin{code}
+getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
+getSimplIntSwitch chkr switch
+  = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
+
+switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
+
+switchIsOn lookup_fn switch
+  = case (lookup_fn switch) of
+      SwBool False -> False
+      _	    	   -> True
 
-cloneIds :: SimplEnv -> [InBinder] -> SmplM [OutId]
-cloneIds env binders = mapSmpl (cloneId env) binders
+intSwitchSet :: (switch -> SwitchResult)
+	     -> (Int -> switch)
+	     -> Maybe Int
+
+intSwitchSet lookup_fn switch
+  = case (lookup_fn (switch (panic "intSwitchSet"))) of
+      SwInt int -> Just int
+      _	    	-> Nothing
 \end{code}
+
+
+These things behave just like enumeration types.
+
+\begin{code}
+instance Eq SimplifierSwitch where
+    a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
+
+instance Ord SimplifierSwitch where
+    a <  b  = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
+    a <= b  = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
+
+
+tagOf_SimplSwitch (MaxSimplifierIterations _)	= _ILIT(1)
+tagOf_SimplSwitch NoCaseOfCase			= _ILIT(2)
+
+-- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
+
+lAST_SIMPL_SWITCH_TAG = 2
+\end{code}
+