%
-% (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}
%************************************************************************
(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)
= 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}
+
projects / ghc-hetmet.git / blobdiff