X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplMonad.lhs;h=1781d56bfbb9ad91104ef5eb6314e787b68edec2;hp=4ad6d53e8d0a0d30fab0f583c7fc611f28ae039e;hb=927df6486bc0dcb598b82702ca40c8fad0d9b25f;hpb=f4c9109d7f1deb6f79c2c141f69ec24b7022776b diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.lhs index 4ad6d53..1781d56 100644 --- a/compiler/simplCore/SimplMonad.lhs +++ b/compiler/simplCore/SimplMonad.lhs @@ -7,48 +7,26 @@ 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 + plusSimplCount, isZeroSimplCount ) 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 Maybes ( expectJust ) -import FiniteMap ( FiniteMap, emptyFM, isEmptyFM, lookupFM, addToFM, plusFM_C, fmToList ) -import FastString ( FastString ) -import Outputable -import FastTypes - -import GHC.Exts ( indexArray# ) - -import Data.Array -import Data.Array.Base (unsafeAt) - -infixr 0 `thenSmpl`, `thenSmpl_` +import UniqSupply +import DynFlags ( DynFlags ) +import CoreMonad +import FastString \end{code} %************************************************************************ @@ -95,7 +73,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 @@ -109,30 +87,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} @@ -143,33 +102,31 @@ mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') -> %************************************************************************ \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} @@ -181,350 +138,17 @@ newId fs ty = getUniqueSmpl `thenSmpl` \ uniq -> \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} - - -%************************************************************************ -%* * -\subsubsection{Command-line switches} -%* * -%************************************************************************ - -\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:) - \ 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! - - -- 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} - -\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 - -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} -