X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplMonad.lhs;h=8a02b174e85631ff8b76f49c5a9804a5de0f98f7;hb=455302c1fd5dba0047e76ad83ec21d2edb9864de;hp=26d19bb05a402b54aad48d2decc36176289f09c6;hpb=a11685b343f5687e812e91d1f0b4bb5ba3b9706a;p=ghc-hetmet.git diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.lhs index 26d19bb..8a02b17 100644 --- a/compiler/simplCore/SimplMonad.lhs +++ b/compiler/simplCore/SimplMonad.lhs @@ -4,19 +4,11 @@ \section[SimplMonad]{The simplifier Monad} \begin{code} -{-# OPTIONS -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/Commentary/CodingStyle#Warnings --- for details - module SimplMonad ( -- The monad SimplM, - initSmpl, returnSmpl, thenSmpl, thenSmpl_, - mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl, - getDOptsSmpl, getRules, getFamEnvs, + initSmpl, + getDOptsSmpl, getSimplRules, getFamEnvs, -- Unique supply MonadUnique(..), newId, @@ -29,11 +21,9 @@ module SimplMonad ( -- 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 ) @@ -41,17 +31,14 @@ 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 Data.Array import Data.Array.Base (unsafeAt) - -infixr 0 `thenSmpl`, `thenSmpl_` \end{code} %************************************************************************ @@ -98,7 +85,7 @@ instance Monad SimplM where 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 @@ -112,30 +99,11 @@ thenSmpl_ m k = 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} @@ -148,22 +116,22 @@ mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') -> \begin{code} instance MonadUnique SimplM where getUniqueSupplyM - = SM (\st_env us sc -> case splitUniqSupply us of + = SM (\_st_env us sc -> case splitUniqSupply us of (us1, us2) -> (us1, us2, sc)) getUniqueM - = SM (\st_env us sc -> case splitUniqSupply us of + = SM (\_st_env us sc -> case splitUniqSupply us of (us1, us2) -> (uniqFromSupply us1, us2, sc)) getUniquesM - = SM (\st_env us sc -> case splitUniqSupply us of + = 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)) @@ -182,22 +150,23 @@ newId fs ty = do uniq <- getUniqueM \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' = 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 (\st_env 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 @@ -208,17 +177,22 @@ 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 - } +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, + -- most recent first + log2 :: [Tick] -- Last opt_HistorySize events before that + -- Having log1, log2 lets us accumulate the + -- recent history reasonably efficiently + } type TickCounts = FiniteMap Tick Int @@ -233,25 +207,19 @@ zeroSimplCount dflags 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 @@ -274,17 +242,17 @@ plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 }) | 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 ] @@ -303,11 +271,9 @@ pprTickCounts ((tick1,n1):ticks) same_tick (tick2,_) = tickToTag tick2 == tick1_tag tot_n = sum [n | (_,n) <- real_these] -pprTCDetails ticks@((tick,_):_) - | verboseSimplStats || isRuleFired tick +pprTCDetails :: [(Tick, Int)] -> SDoc +pprTCDetails ticks = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks]) - | otherwise - = empty \end{code} %************************************************************************ @@ -341,14 +307,13 @@ data Tick | 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 } + a == b = case a `cmpTick` b of + EQ -> True + _ -> False instance Ord Tick where compare = cmpTick @@ -407,16 +372,13 @@ pprTickCts (AltMerge v) = ppr v 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 GT -> GT - EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b - | otherwise -> EQ + EQ -> cmpEqTick a b 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 @@ -433,7 +395,7 @@ 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 +cmpEqTick _ _ = EQ \end{code} @@ -451,6 +413,9 @@ data SwitchResult | 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. @@ -482,7 +447,7 @@ isAmongSimpl on_switches -- Switches mentioned later occur *earlier* 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} @@ -521,11 +486,13 @@ instance Ord SimplifierSwitch where 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}