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

diff --git a/compiler/simplStg/SRT.lhs b/compiler/simplStg/SRT.lhs
index cd118d7..dfd9832 100644
--- a/compiler/simplStg/SRT.lhs
+++ b/compiler/simplStg/SRT.lhs
@@ -7,18 +7,25 @@ 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 -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/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
 import Id        	( Id )
 import VarSet
 import VarEnv
-import Util		( sortLe )
-import Maybes		( orElse )
-import Maybes		( expectJust )
-import Bitmap		( intsToBitmap )
+import Maybes		( orElse, expectJust )
+import Bitmap
 
 #ifdef DEBUG
 import Outputable
@@ -27,7 +34,6 @@ import Outputable
 import List
 
 import Util
-import Outputable
 \end{code}
 
 \begin{code}
@@ -42,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
@@ -67,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
@@ -99,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)
@@ -109,13 +117,15 @@ 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
 
+srtExpr table (StgTick m n expr) = StgTick m n $! srtExpr table expr
+
 srtExpr table (StgCase scrut live1 live2 uniq srt alt_type alts)
  = StgCase expr' live1 live2 uniq srt' alt_type alts'
  where
@@ -134,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
@@ -147,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)
@@ -160,6 +170,7 @@ constructSRT table (SRTEntries entries)
 -- ---------------------------------------------------------------------------
 -- Misc stuff
 
+(=:) :: a -> (a -> b) -> b
 a =: k  = k a
 
 \end{code}