X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplMonad.lhs;h=514fda65468028d54ffb4e2510dbc67c5b857255;hp=be51d7d684f190bebba891ba7a59a24ec72cebef;hb=f96194794bf099020706c3816d1a5678b40addbb;hpb=4033c3e0f46673b3d1af253552583e94c663bff8

diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.lhs
index be51d7d..514fda6 100644
--- a/compiler/simplCore/SimplMonad.lhs
+++ b/compiler/simplCore/SimplMonad.lhs
@@ -8,7 +8,7 @@ module SimplMonad (
 	-- The monad
 	SimplM,
 	initSmpl,
-	getDOptsSmpl, getRules, getFamEnvs,
+	getDOptsSmpl, getSimplRules, getFamEnvs,
 
         -- Unique supply
         MonadUnique(..), newId,
@@ -32,7 +32,7 @@ import UniqSupply
 import DynFlags		( SimplifierSwitch(..), DynFlags, DynFlag(..), dopt )
 import StaticFlags	( opt_PprStyle_Debug, opt_HistorySize )
 import Maybes		( expectJust )
-import FiniteMap	( FiniteMap, emptyFM, isEmptyFM, lookupFM, addToFM, plusFM_C, fmToList )
+import FiniteMap	( FiniteMap, emptyFM, lookupFM, addToFM, plusFM_C, fmToList )
 import FastString
 import Outputable
 import FastTypes
@@ -101,9 +101,9 @@ thenSmpl_ m k
 		(_, 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]) #-}
+-- {-# 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}
 
 
@@ -130,8 +130,8 @@ instance MonadUnique SimplM where
 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))
@@ -205,16 +205,9 @@ isZeroSimplCount (SimplCount { ticks = 0 }) = True
 isZeroSimplCount _    			    = False
 
 doFreeTick tick sc@SimplCount { details = dts } 
-  = dts' `seqFM` sc { details = dts' }
-  where
-    dts' = dts `addTick` tick 
+  = sc { details = dts `addTick` tick }
 doFreeTick _ sc = sc 
 
--- Gross hack to persuade GHC 3.03 to do this important seq
-seqFM :: FiniteMap key elt -> t -> t
-seqFM fm x | isEmptyFM fm = x
-	   | otherwise    = x
-
 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 }
@@ -250,10 +243,10 @@ 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 "",
+	  blankLine,
 	  pprTickCounts (fmToList dts),
 	  if verboseSimplStats then
-		vcat [text "",
+		vcat [blankLine,
 		      ptext (sLit "Log (most recent first)"),
 		      nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
 	  else empty