\section[SimplMonad]{The simplifier Monad}
\begin{code}
-{-# OPTIONS_GHC -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
--- for details
-
module SimplMonad (
-- The monad
SimplM,
- initSmpl, returnSmpl, thenSmpl, thenSmpl_,
- mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl,
- getDOptsSmpl, getRules, getFamEnvs,
+ initSmpl,
+ getDOptsSmpl, getSimplRules, getFamEnvs,
-- Unique supply
- getUniqueSmpl, getUniquesSmpl, getUniqSupplySmpl, newId,
+ MonadUnique(..), newId,
-- Counting
- SimplCount, Tick(..),
- tick, freeTick,
+ SimplCount, tick, freeTick,
getSimplCount, zeroSimplCount, pprSimplCount,
plusSimplCount, isZeroSimplCount,
-- Switch checker
SwitchChecker, SwitchResult(..), getSimplIntSwitch,
- isAmongSimpl, intSwitchSet, switchIsOn
+ isAmongSimpl, intSwitchSet, switchIsOn, allOffSwitchChecker
) where
-#include "HsVersions.h"
-
import Id ( Id, mkSysLocal )
import Type ( Type )
import FamInstEnv ( FamInstEnv )
import Rules ( RuleBase )
-import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
- UniqSupply
- )
-import DynFlags ( SimplifierSwitch(..), DynFlags, DynFlag(..), dopt )
-import StaticFlags ( opt_PprStyle_Debug, opt_HistorySize )
-import Unique ( Unique )
+import UniqSupply
+import DynFlags ( DynFlags )
import Maybes ( expectJust )
-import FiniteMap ( FiniteMap, emptyFM, isEmptyFM, lookupFM, addToFM, plusFM_C, fmToList )
-import FastString ( FastString )
+import CoreMonad
+import FastString
import Outputable
import FastTypes
-import GHC.Exts ( indexArray# )
-
import Data.Array
import Data.Array.Base (unsafeAt)
-
-infixr 0 `thenSmpl`, `thenSmpl_`
\end{code}
%************************************************************************
return = returnSmpl
returnSmpl :: a -> SimplM a
-returnSmpl e = SM (\ st_env us sc -> (e, us, sc))
+returnSmpl e = SM (\_st_env us sc -> (e, us, sc))
thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
= SM (\st_env us0 sc0 ->
case (unSM m st_env us0 sc0) of
(_, us1, sc1) -> unSM k st_env us1 sc1)
-\end{code}
-
-\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` \ x' ->
- mapSmpl f xs `thenSmpl` \ xs' ->
- returnSmpl (x':xs')
-
-mapAndUnzipSmpl f [] = returnSmpl ([],[])
-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')
+-- TODO: this specializing is not allowed
+-- {-# SPECIALIZE mapM :: (a -> SimplM b) -> [a] -> SimplM [b] #-}
+-- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-}
+-- {-# SPECIALIZE mapAccumLM :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-}
\end{code}
%************************************************************************
\begin{code}
-getUniqSupplySmpl :: SimplM UniqSupply
-getUniqSupplySmpl
- = SM (\st_env us sc -> case splitUniqSupply us of
- (us1, us2) -> (us1, us2, sc))
+instance MonadUnique SimplM where
+ getUniqueSupplyM
+ = SM (\_st_env us sc -> case splitUniqSupply us of
+ (us1, us2) -> (us1, us2, sc))
-getUniqueSmpl :: SimplM Unique
-getUniqueSmpl
- = SM (\st_env us sc -> case splitUniqSupply us of
- (us1, us2) -> (uniqFromSupply us1, us2, sc))
+ getUniqueM
+ = SM (\_st_env us sc -> case splitUniqSupply us of
+ (us1, us2) -> (uniqFromSupply us1, us2, sc))
-getUniquesSmpl :: SimplM [Unique]
-getUniquesSmpl
- = SM (\st_env us sc -> case splitUniqSupply us of
- (us1, us2) -> (uniqsFromSupply us1, us2, sc))
+ getUniquesM
+ = SM (\_st_env us sc -> case splitUniqSupply us of
+ (us1, us2) -> (uniqsFromSupply us1, us2, sc))
getDOptsSmpl :: SimplM DynFlags
getDOptsSmpl = SM (\st_env us sc -> (st_flags st_env, us, sc))
-getRules :: SimplM RuleBase
-getRules = SM (\st_env us sc -> (st_rules st_env, us, sc))
+getSimplRules :: SimplM RuleBase
+getSimplRules = SM (\st_env us sc -> (st_rules st_env, us, sc))
getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
getFamEnvs = SM (\st_env us sc -> (st_fams st_env, us, sc))
newId :: FastString -> Type -> SimplM Id
-newId fs ty = getUniqueSmpl `thenSmpl` \ uniq ->
- returnSmpl (mkSysLocal fs uniq ty)
+newId fs ty = do uniq <- getUniqueM
+ return (mkSysLocal fs uniq ty)
\end{code}
\begin{code}
getSimplCount :: SimplM SimplCount
-getSimplCount = SM (\st_env us sc -> (sc, us, sc))
+getSimplCount = SM (\_st_env us sc -> (sc, us, sc))
tick :: Tick -> SimplM ()
tick t
- = SM (\st_env us sc -> let sc' = doTick t sc
- in sc' `seq` ((), us, 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
- in sc' `seq` ((), us, sc'))
-\end{code}
-
-\begin{code}
-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
- 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
- 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
- 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{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
-
-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
+ = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc
+ in sc' `seq` ((), us, sc'))
\end{code}
| SwString FastString -- nothing or a String
| SwInt Int -- nothing or an Int
+allOffSwitchChecker :: SwitchChecker
+allOffSwitchChecker _ = SwBool False
+
isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
isAmongSimpl on_switches -- Switches mentioned later occur *earlier*
-- in the list; defaults right at the end.
-- (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!
then switches_so_far
else switch : switches_so_far
where
- sw `is_elem` [] = False
+ _ `is_elem` [] = False
sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
|| sw `is_elem` ss
\end{code}
a <= b = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
-tagOf_SimplSwitch (MaxSimplifierIterations _) = _ILIT(1)
-tagOf_SimplSwitch NoCaseOfCase = _ILIT(2)
+tagOf_SimplSwitch :: SimplifierSwitch -> FastInt
+tagOf_SimplSwitch NoCaseOfCase = _ILIT(1)
-- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
+lAST_SIMPL_SWITCH_TAG :: Int
lAST_SIMPL_SWITCH_TAG = 2
\end{code}