%
% (c) The GRASP/AQUA Project, Glasgow University, 1998
%
Run through the STG code and compute the Static Reference Table for
each letbinding. At the same time, we figure out which toplevel
bindings have no CAF references, and record the fact in their IdInfo.
\begin{code}
module SRT( computeSRTs ) where
#include "HsVersions.h"
import StgSyn
import Id ( Id )
import VarSet
import VarEnv
import Maybes ( orElse, expectJust )
import Bitmap
import Outputable
import Util
\end{code}
\begin{code}
computeSRTs :: [StgBinding] -> [(StgBinding,[(Id,[Id])])]
computeSRTs binds = srtTopBinds emptyVarEnv binds
srtTopBinds :: IdEnv Id -> [StgBinding] -> [(StgBinding, [(Id,[Id])])]
srtTopBinds _ [] = []
srtTopBinds env (StgNonRec b rhs : binds) =
(StgNonRec b rhs', [(b,srt')]) : srtTopBinds env' binds
where
(rhs', srt) = srtTopRhs b rhs
env' = maybeExtendEnv env b rhs
srt' = applyEnvList env srt
srtTopBinds env (StgRec bs : binds) =
(StgRec (zip bndrs rhss), zip bndrs srts') : srtTopBinds env binds
where
(rhss, srts) = unzip [ srtTopRhs b r | (b,r) <- bs ]
bndrs = map fst bs
srts' = map (applyEnvList env) srts
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 _ _ = env
applyEnvList :: IdEnv Id -> [Id] -> [Id]
applyEnvList env = map (applyEnv env)
applyEnv :: IdEnv Id -> Id -> Id
applyEnv env id = lookupVarEnv env id `orElse` id
srtTopRhs :: Id -> StgRhs -> (StgRhs, [Id])
srtTopRhs _ rhs@(StgRhsCon _ _ _) = (rhs, [])
srtTopRhs _ rhs@(StgRhsClosure _ _ _ _ (SRTEntries cafs) _ _)
= (srtRhs table rhs, elems)
where
elems = varSetElems cafs
table = mkVarEnv (zip elems [0..])
srtBind :: IdEnv Int -> StgBinding -> StgBinding
srtBind table (StgNonRec binder rhs) = StgNonRec binder (srtRhs table rhs)
srtBind table (StgRec pairs) = StgRec [ (b, srtRhs table r) | (b,r) <- pairs ]
srtRhs :: IdEnv Int -> StgRhs -> StgRhs
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 _ 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
expr' = srtExpr table scrut
srt' = constructSRT table srt
alts' = map (srtAlt table) alts
srtExpr table (StgLet bind body)
= srtBind table bind =: \ bind' ->
srtExpr table body =: \ body' ->
StgLet bind' body'
srtExpr table (StgLetNoEscape live1 live2 bind body)
= srtBind table bind =: \ bind' ->
srtExpr table body =: \ body' ->
StgLetNoEscape live1 live2 bind' body'
srtExpr _table expr = pprPanic "srtExpr" (ppr expr)
srtAlt :: IdEnv Int -> StgAlt -> StgAlt
srtAlt table (con,args,used,rhs)
= (,,,) con args used $! srtExpr table rhs
constructSRT :: IdEnv Int -> SRT -> SRT
constructSRT table (SRTEntries entries)
| isEmptyVarSet entries = NoSRT
| otherwise = seqBitmap bitmap $ SRT offset len bitmap
where
ints = map (expectJust "constructSRT" . lookupVarEnv table)
(varSetElems entries)
sorted_ints = sortLe (<=) ints
offset = head sorted_ints
bitmap_entries = map (subtract offset) sorted_ints
len = last bitmap_entries + 1
bitmap = intsToBitmap len bitmap_entries
(=:) :: a -> (a -> b) -> b
a =: k = k a
\end{code}