module SimplMonad (
-- The monad
SimplM,
- initSmpl, returnSmpl, thenSmpl, thenSmpl_,
- mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl,
- getDOptsSmpl,
+ 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 UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
- UniqSupply
- )
-import DynFlags ( SimplifierSwitch(..), DynFlags, DynFlag(..), dopt )
-import StaticFlags ( opt_PprStyle_Debug, opt_HistorySize )
-import Unique ( Unique )
+import FamInstEnv ( FamInstEnv )
+import Rules ( RuleBase )
+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# )
-
-#if __GLASGOW_HASKELL__ < 503
-import PrelArr ( Array(..) )
-#else
-import GHC.Arr ( Array(..) )
-#endif
-
-import Array ( array, (//) )
-
-infixr 0 `thenSmpl`, `thenSmpl_`
+import Data.Array
+import Data.Array.Base (unsafeAt)
\end{code}
%************************************************************************
\begin{code}
newtype SimplM result
- = SM { unSM :: DynFlags -- We thread the unique supply because
- -> UniqSupply -- constantly splitting it is rather expensive
- -> SimplCount
- -> (result, UniqSupply, SimplCount)}
+ = SM { unSM :: SimplTopEnv -- Envt that does not change much
+ -> UniqSupply -- We thread the unique supply because
+ -- constantly splitting it is rather expensive
+ -> SimplCount
+ -> (result, UniqSupply, SimplCount)}
+
+data SimplTopEnv = STE { st_flags :: DynFlags
+ , st_rules :: RuleBase
+ , st_fams :: (FamInstEnv, FamInstEnv) }
\end{code}
\begin{code}
-initSmpl :: DynFlags
+initSmpl :: DynFlags -> RuleBase -> (FamInstEnv, FamInstEnv)
-> UniqSupply -- No init count; set to 0
-> SimplM a
-> (a, SimplCount)
-initSmpl dflags us m
- = case unSM m dflags us (zeroSimplCount dflags) of
+initSmpl dflags rules fam_envs us m
+ = case unSM m env us (zeroSimplCount dflags) of
(result, _, count) -> (result, count)
-
+ where
+ env = STE { st_flags = dflags, st_rules = rules, st_fams = fam_envs }
{-# INLINE thenSmpl #-}
{-# INLINE thenSmpl_ #-}
return = returnSmpl
returnSmpl :: a -> SimplM a
-returnSmpl e = SM (\ dflags 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
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 )
+ = SM (\ st_env us0 sc0 ->
+ case (unSM m st_env us0 sc0) of
+ (m_result, us1, sc1) -> unSM (k m_result) st_env 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}
-
-
-\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')
+ = SM (\st_env us0 sc0 ->
+ case (unSM m st_env us0 sc0) of
+ (_, us1, sc1) -> unSM k st_env us1 sc1)
+
+-- 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 (\dflags 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 (\dflags 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 (\dflags 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 (\dflags us sc -> (dflags, us, sc))
+getDOptsSmpl = SM (\st_env us sc -> (st_flags 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 (\dflags us sc -> (sc, us, sc))
+getSimplCount = SM (\_st_env us sc -> (sc, us, sc))
tick :: Tick -> SimplM ()
tick t
- = SM (\dflags 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 (\dflags 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.
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
- }
+ \ 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}