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

diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.lhs
index 26d19bb..514fda6 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,
@@ -32,8 +24,6 @@ module SimplMonad (
 	isAmongSimpl, intSwitchSet, switchIsOn
     ) 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
@@ -233,25 +202,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 +237,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 +266,13 @@ pprTickCounts ((tick1,n1):ticks)
     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}
 
 %************************************************************************
@@ -341,14 +306,17 @@ data Tick
   | 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
@@ -407,7 +375,7 @@ 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
@@ -433,7 +401,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}
 
 
@@ -482,7 +450,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 +489,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}