X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplStg%2FSRT.lhs;h=abad3ce48dfd67cd660b06d5f719747cb4b3ba3d;hp=59ce71c89a0732947e1b55834e4a24099d8fc337;hb=cbd7463c986d54422de15cb3b56184de116ef7ba;hpb=7fc749a43b4b6b85d234fa95d4928648259584f4

diff --git a/compiler/simplStg/SRT.lhs b/compiler/simplStg/SRT.lhs
index 59ce71c..abad3ce 100644
--- a/compiler/simplStg/SRT.lhs
+++ b/compiler/simplStg/SRT.lhs
@@ -7,7 +7,7 @@ each let-binding.  At the same time, we figure out which top-level
 bindings have no CAF references, and record the fact in their IdInfo.
 
 \begin{code}
-{-# OPTIONS -w #-}
+{-# OPTIONS -fno-warn-incomplete-patterns #-}
 -- 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
@@ -23,13 +23,9 @@ import Id        	( Id )
 import VarSet
 import VarEnv
 import Maybes		( orElse, expectJust )
-import Bitmap		( intsToBitmap )
+import Bitmap
 
-#ifdef DEBUG
 import Outputable
-#endif
-
-import List
 
 import Util
 \end{code}
@@ -46,7 +42,7 @@ computeSRTs binds = srtTopBinds emptyVarEnv binds
 
 srtTopBinds :: IdEnv Id -> [StgBinding] -> [(StgBinding, [(Id,[Id])])]
 
-srtTopBinds env [] = []
+srtTopBinds _   [] = []
 srtTopBinds env (StgNonRec b rhs : binds) = 
   (StgNonRec b rhs', [(b,srt')]) : srtTopBinds env' binds
   where
@@ -71,22 +67,24 @@ srtTopBinds env (StgRec bs : binds) =
 -- this information across module boundaries too, but we currently
 -- don't.
 
+maybeExtendEnv ::IdEnv Id -> Id -> StgRhs -> IdEnv Id
 maybeExtendEnv env bndr (StgRhsClosure _ _ _ ReEntrant (SRTEntries cafs) _ _)
   | [one] <- varSetElems cafs
   = extendVarEnv env bndr (applyEnv env one)
-maybeExtendEnv env bndr _ = env
+maybeExtendEnv env _ _ = env
 
 applyEnvList :: IdEnv Id -> [Id] -> [Id]
 applyEnvList env = map (applyEnv env)
 
+applyEnv :: IdEnv Id -> Id -> Id
 applyEnv env id = lookupVarEnv env id `orElse` id
 
 -- ----  Top-level right hand sides:
 
 srtTopRhs :: Id -> StgRhs -> (StgRhs, [Id])
 
-srtTopRhs binder rhs@(StgRhsCon _ _ _) = (rhs, [])
-srtTopRhs binder rhs@(StgRhsClosure _ _ _ _  (SRTEntries cafs) _ _)
+srtTopRhs _ rhs@(StgRhsCon _ _ _) = (rhs, [])
+srtTopRhs _ rhs@(StgRhsClosure _ _ _ _  (SRTEntries cafs) _ _)
   = (srtRhs table rhs, elems)
   where
 	elems = varSetElems cafs
@@ -103,7 +101,7 @@ srtBind table (StgRec pairs) = StgRec [ (b, srtRhs table r) | (b,r) <- pairs ]
 
 srtRhs :: IdEnv Int -> StgRhs -> StgRhs
 
-srtRhs table e@(StgRhsCon cc con args) = e
+srtRhs _     e@(StgRhsCon _ _ _) = e
 srtRhs table (StgRhsClosure cc bi free_vars u srt args body)
   = StgRhsClosure cc bi free_vars u (constructSRT table srt) args 
 	$! (srtExpr table body)
@@ -113,10 +111,10 @@ srtRhs table (StgRhsClosure cc bi free_vars u srt args body)
 
 srtExpr :: IdEnv Int -> StgExpr -> StgExpr
 
-srtExpr table e@(StgApp f args) 	= e
-srtExpr table e@(StgLit l)      	= e
-srtExpr table e@(StgConApp con args)    = e
-srtExpr table e@(StgOpApp op args ty)   = e
+srtExpr _ e@(StgApp _ _)       = e
+srtExpr _ e@(StgLit _)         = e
+srtExpr _ e@(StgConApp _ _)    = e
+srtExpr _ e@(StgOpApp _ _ _)   = e
 
 srtExpr table (StgSCC cc expr) = StgSCC cc $! srtExpr table expr
 
@@ -139,9 +137,7 @@ srtExpr table (StgLetNoEscape live1 live2 bind body)
     srtExpr table body		   =: \ body' ->
     StgLetNoEscape live1 live2 bind' body'
 
-#ifdef DEBUG
-srtExpr table expr = pprPanic "srtExpr" (ppr expr)
-#endif
+srtExpr _table expr = pprPanic "srtExpr" (ppr expr)
 
 srtAlt :: IdEnv Int -> StgAlt -> StgAlt
 srtAlt table (con,args,used,rhs)
@@ -153,7 +149,7 @@ srtAlt table (con,args,used,rhs)
 constructSRT :: IdEnv Int -> SRT -> SRT
 constructSRT table (SRTEntries entries)
  | isEmptyVarSet entries = NoSRT
- | otherwise  = SRT offset len bitmap
+ | otherwise  = seqBitmap bitmap $ SRT offset len bitmap
   where
     ints = map (expectJust "constructSRT" . lookupVarEnv table) 
 		(varSetElems entries)
@@ -166,6 +162,7 @@ constructSRT table (SRTEntries entries)
 -- ---------------------------------------------------------------------------
 -- Misc stuff
 
+(=:) :: a -> (a -> b) -> b
 a =: k  = k a
 
 \end{code}