X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplMonad.lhs;h=4265efb3f070d9fd41e642aeb4c8dce91faa9d06;hb=e58ae70175e979bc9f2977ede8b445055b7123e8;hp=5b6ac4001aa0d2e6c40e60206004d173583e9b36;hpb=49c98d143c382a1341e1046f5ca00819a25691ba;p=ghc-hetmet.git diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.lhs index 5b6ac40..4265efb 100644 --- a/compiler/simplCore/SimplMonad.lhs +++ b/compiler/simplCore/SimplMonad.lhs @@ -4,15 +4,21 @@ \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, + initSmpl, + getDOptsSmpl, getRules, getFamEnvs, -- Unique supply - getUniqueSmpl, getUniquesSmpl, getUniqSupplySmpl, newId, + MonadUnique(..), newId, -- Counting SimplCount, Tick(..), @@ -25,33 +31,22 @@ module SimplMonad ( 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 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} %************************************************************************ @@ -65,22 +60,28 @@ For the simplifier monad, we want to {\em thread} a unique supply and a counter. \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_ #-} @@ -92,44 +93,25 @@ instance Monad SimplM where 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} @@ -140,28 +122,31 @@ mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') -> %************************************************************************ \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)) + +getRules :: SimplM RuleBase +getRules = 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} @@ -173,18 +158,18 @@ newId fs ty = getUniqueSmpl `thenSmpl` \ uniq -> \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 + = 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 + = SM (\st_env us sc -> let sc' = doFreeTick t sc in sc' `seq` ((), us, sc')) \end{code} @@ -267,15 +252,15 @@ plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 }) plusSimplCount VerySimplZero VerySimplZero = VerySimplZero plusSimplCount sc1 sc2 = 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, + = vcat [ptext (sLit "Total ticks: ") <+> int tks, text "", pprTickCounts (fmToList dts), if verboseSimplStats then vcat [text "", - ptext SLIT("Log (most recent first)"), + ptext (sLit "Log (most recent first)"), nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))] else empty ] @@ -460,11 +445,7 @@ isAmongSimpl on_switches -- Switches mentioned later occur *earlier* 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)