X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplStg%2FSRT.lhs;h=dfd98329a116f83a75ed40cbfbf61f4ed642d095;hp=fed0a64a6bd3d3e2f42ac85b0aa2928dc2f88286;hb=8d84d843da4886861b2b27236b413ad135666653;hpb=17b297d97d327620ed6bfab942f8992b2446f1bf

diff --git a/compiler/simplStg/SRT.lhs b/compiler/simplStg/SRT.lhs
index fed0a64..dfd9832 100644
--- a/compiler/simplStg/SRT.lhs
+++ b/compiler/simplStg/SRT.lhs
@@ -7,15 +7,17 @@ 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_GHC -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
---     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
 -- for details
 
 module SRT( computeSRTs ) where
 
+-- XXX This define is a bit of a hack, and should be done more nicely
+#define FAST_STRING_NOT_NEEDED 1
 #include "HsVersions.h"
 
 import StgSyn
@@ -23,7 +25,7 @@ import Id        	( Id )
 import VarSet
 import VarEnv
 import Maybes		( orElse, expectJust )
-import Bitmap		( intsToBitmap )
+import Bitmap
 
 #ifdef DEBUG
 import Outputable
@@ -46,7 +48,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 +73,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 +107,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 +117,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
 
@@ -140,7 +144,7 @@ srtExpr table (StgLetNoEscape live1 live2 bind body)
     StgLetNoEscape live1 live2 bind' body'
 
 #ifdef DEBUG
-srtExpr table expr = pprPanic "srtExpr" (ppr expr)
+srtExpr _table expr = pprPanic "srtExpr" (ppr expr)
 #endif
 
 srtAlt :: IdEnv Int -> StgAlt -> StgAlt
@@ -153,7 +157,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 +170,7 @@ constructSRT table (SRTEntries entries)
 -- ---------------------------------------------------------------------------
 -- Misc stuff
 
+(=:) :: a -> (a -> b) -> b
 a =: k  = k a
 
 \end{code}