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(..),
isAmongSimpl, intSwitchSet, switchIsOn
) where
-#include "HsVersions.h"
-
import Id ( Id, mkSysLocal )
import Type ( Type )
-import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
- UniqSupply
- )
+import FamInstEnv ( FamInstEnv )
+import Rules ( RuleBase )
+import UniqSupply
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 FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, plusFM_C, fmToList )
+import 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 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' = 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'))
+ = SM (\_st_env us sc -> let sc' = doFreeTick t sc
+ in sc' `seq` ((), us, sc'))
\end{code}
\begin{code}
+verboseSimplStats :: Bool
verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
zeroSimplCount :: DynFlags -> SimplCount
isZeroSimplCount VerySimplZero = True
isZeroSimplCount (SimplCount { ticks = 0 }) = True
-isZeroSimplCount other = False
+isZeroSimplCount _ = 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
+ = sc { details = dts `addTick` tick }
+doFreeTick _ sc = sc
-doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1, log2 = l2 }
+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 tick sc = VerySimplNonZero -- The very simple case
+doTick _ _ = VerySimplNonZero -- The very simple case
-- Don't use plusFM_C because that's lazy, and we want to
| otherwise = sc2
plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
-plusSimplCount sc1 sc2 = VerySimplNonZero
+plusSimplCount _ _ = VerySimplNonZero
-pprSimplCount VerySimplZero = ptext SLIT("Total ticks: ZERO!")
-pprSimplCount VerySimplNonZero = ptext SLIT("Total ticks: NON-ZERO!")
+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 "",
+ = vcat [ptext (sLit "Total ticks: ") <+> int tks,
+ blankLine,
pprTickCounts (fmToList dts),
if verboseSimplStats then
- vcat [text "",
- ptext SLIT("Log (most recent first)"),
+ vcat [blankLine,
+ ptext (sLit "Log (most recent first)"),
nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
else empty
]
same_tick (tick2,_) = tickToTag tick2 == tick1_tag
tot_n = sum [n | (_,n) <- real_these]
+pprTCDetails :: [(Tick, Int)] -> SDoc
pprTCDetails ticks@((tick,_):_)
| verboseSimplStats || isRuleFired tick
= nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
| otherwise
= empty
+pprTCDetails [] = panic "pprTCDetails []"
\end{code}
%************************************************************************
| BottomFound
| SimplifierDone -- Ticked at each iteration of the simplifier
+isRuleFired :: Tick -> Bool
isRuleFired (RuleFired _) = True
-isRuleFired other = False
+isRuleFired _ = 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 }
+ a == b = case a `cmpTick` b of
+ EQ -> True
+ _ -> False
instance Ord Tick where
compare = cmpTick
pprTickCts (CaseElim v) = ppr v
pprTickCts (CaseIdentity v) = ppr v
pprTickCts (FillInCaseDefault v) = ppr v
-pprTickCts other = empty
+pprTickCts _ = empty
cmpTick :: Tick -> Tick -> Ordering
cmpTick a b = case (tickToTag a `compare` tickToTag b) of
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
+cmpEqTick _ _ = EQ
\end{code}
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)
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 :: SimplifierSwitch -> FastInt
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 :: Int
lAST_SIMPL_SWITCH_TAG = 2
\end{code}
projects / ghc-hetmet.git / blobdiff