X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FCoreMonad.lhs;h=00dedffa38129353305a4f0ce985594359a1a8d0;hp=f9ff5e75d132d6507f577bac3bcccf919915b100;hb=e95ee1f718c6915c478005aad8af81705357d6ab;hpb=d4f4391a030e683572eee01291cc8bc6203dbf5d

diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs
index f9ff5e7..00dedff 100644
--- a/compiler/simplCore/CoreMonad.lhs
+++ b/compiler/simplCore/CoreMonad.lhs
@@ -15,7 +15,7 @@ module CoreMonad (
     getCoreToDo, dumpSimplPhase,
 
     -- * Counting
-    SimplCount, doSimplTick, doFreeSimplTick,
+    SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
     pprSimplCount, plusSimplCount, zeroSimplCount, isZeroSimplCount, Tick(..),
 
     -- * The monad
@@ -78,13 +78,14 @@ import qualified ErrUtils as Err
 import Bag
 import Maybes
 import UniqSupply
-import LazyUniqFM       ( UniqFM, mapUFM, filterUFM )
-import FiniteMap
+import UniqFM       ( UniqFM, mapUFM, filterUFM )
 
 import Util		( split )
 import Data.List	( intersperse )
 import Data.Dynamic
 import Data.IORef
+import Data.Map (Map)
+import qualified Data.Map as Map
 import Data.Word
 import Control.Monad
 
@@ -166,6 +167,11 @@ displayLintResults dflags pass warns errs binds
        ; Err.ghcExit dflags 1 }
 
   | not (isEmptyBag warns)
+  , not (case pass of { CoreDesugar -> True; _ -> False })
+    	-- Suppress warnings after desugaring pass because some
+	-- are legitimate. Notably, the desugarer generates instance
+	-- methods with INLINE pragmas that form a mutually recursive
+	-- group.  Only afer a round of simplification are they unravelled.
   , not opt_NoDebugOutput
   , showLintWarnings pass
   = printDump (banner "warnings" $$ Err.pprMessageBag warns)
@@ -381,17 +387,11 @@ getCoreToDo dflags
         -- initial simplify: mk specialiser happy: minimum effort please
     simpl_gently = CoreDoSimplify 
                        (SimplGently { sm_rules = True, sm_inline = False })
+			  -- See Note [Gentle mode] and
+			  -- Note [RULEs enabled in SimplGently] in SimplUtils
                        max_iter
                        [
-                        --      Simplify "gently"
-                        -- Don't inline anything till full laziness has bitten
-                        -- In particular, inlining wrappers inhibits floating
-                        -- e.g. ...(case f x of ...)...
-                        --  ==> ...(case (case x of I# x# -> fw x#) of ...)...
-                        --  ==> ...(case x of I# x# -> case fw x# of ...)...
-                        -- and now the redex (f x) isn't floatable any more
-                        -- Similarly, don't apply any rules until after full
-                        -- laziness.  Notably, list fusion can prevent floating.
+
 
             NoCaseOfCase        -- Don't do case-of-case transformations.
                                 -- This makes full laziness work better
@@ -546,9 +546,7 @@ plusSimplCount     :: SimplCount -> SimplCount -> SimplCount
 
 \begin{code}
 data SimplCount 
-   = VerySimplZero		-- These two are used when 
-   | VerySimplNonZero	-- we are only interested in 
-				-- termination info
+   = VerySimplCount !Int	-- Used when don't want detailed stats
 
    | SimplCount	{
 	ticks   :: !Int,	-- Total ticks
@@ -562,20 +560,23 @@ data SimplCount
 				-- recent history reasonably efficiently
      }
 
-type TickCounts = FiniteMap Tick Int
+type TickCounts = Map Tick Int
+
+simplCountN :: SimplCount -> Int
+simplCountN (VerySimplCount n)         = n
+simplCountN (SimplCount { ticks = n }) = n
 
 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,
+  = SimplCount {ticks = 0, details = Map.empty,
                 n_log = 0, log1 = [], log2 = []}
   | otherwise
-  = VerySimplZero
+  = VerySimplCount 0
 
-isZeroSimplCount VerySimplZero    	    = True
-isZeroSimplCount (SimplCount { ticks = 0 }) = True
-isZeroSimplCount _    			    = False
+isZeroSimplCount (VerySimplCount n)    	    = n==0
+isZeroSimplCount (SimplCount { ticks = n }) = n==0
 
 doFreeSimplTick tick sc@SimplCount { details = dts } 
   = sc { details = dts `addTick` tick }
@@ -587,37 +588,37 @@ doSimplTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 =
   where
     sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
 
-doSimplTick _ _ = VerySimplNonZero -- The very simple case
+doSimplTick _ (VerySimplCount n) = VerySimplCount (n+1)
 
 
--- Don't use plusFM_C because that's lazy, and we want to 
+-- Don't use Map.unionWith 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
+addTick fm tick = case Map.lookup tick fm of
+			Nothing -> Map.insert tick 1 fm
+			Just n  -> n1 `seq` Map.insert tick n1 fm
 				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 }
+  = log_base { ticks = tks1 + tks2, details = Map.unionWith (+) 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 _             _             = VerySimplNonZero
+plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)
+plusSimplCount _                  _                  = panic "plusSimplCount"
+       -- We use one or the other consistently
 
-pprSimplCount VerySimplZero    = ptext (sLit "Total ticks: ZERO!")
-pprSimplCount VerySimplNonZero = ptext (sLit "Total ticks: NON-ZERO!")
+pprSimplCount (VerySimplCount n) = ptext (sLit "Total ticks:") <+> int n
 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
   = vcat [ptext (sLit "Total ticks:    ") <+> int tks,
 	  blankLine,
-	  pprTickCounts (fmToList dts),
+	  pprTickCounts (Map.toList dts),
 	  if verboseSimplStats then
 		vcat [blankLine,
 		      ptext (sLit "Log (most recent first)"),