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
#include "HsVersions.h"
import VarSet
import VarEnv
import Maybes ( orElse, expectJust )
-import Bitmap ( intsToBitmap )
+import Bitmap
-#ifdef DEBUG
import Outputable
-#endif
-
-import List
import Util
\end{code}
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
-- 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
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)
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 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)
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)
-- ---------------------------------------------------------------------------
-- Misc stuff
+(=:) :: a -> (a -> b) -> b
a =: k = k a
\end{code}